/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompcmds.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompcmds.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 44 by dashley, Fri Oct 14 02:09:58 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclcompcmds.c,v 1.1.1.1 2001/06/13 04:35:34 dtashley Exp $ */  
   
 /*  
  * tclCompCmds.c --  
  *  
  *      This file contains compilation procedures that compile various  
  *      Tcl commands into a sequence of instructions ("bytecodes").  
  *  
  * Copyright (c) 1997-1998 Sun Microsystems, Inc.  
  *  
  * See the file "license.terms" for information on usage and redistribution  
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.  
  *  
  * RCS: @(#) $Id: tclcompcmds.c,v 1.1.1.1 2001/06/13 04:35:34 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclCompile.h"  
   
 /*  
  * Prototypes for procedures defined later in this file:  
  */  
   
 static ClientData       DupForeachInfo _ANSI_ARGS_((ClientData clientData));  
 static void             FreeForeachInfo _ANSI_ARGS_((  
                             ClientData clientData));  
   
 /*  
  * The structures below define the AuxData types defined in this file.  
  */  
   
 AuxDataType tclForeachInfoType = {  
     "ForeachInfo",                              /* name */  
     DupForeachInfo,                             /* dupProc */  
     FreeForeachInfo                             /* freeProc */  
 };  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileBreakCmd --  
  *  
  *      Procedure called to compile the "break" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK unless  
  *      there was an error during compilation. If an error occurs then  
  *      the interpreter's result contains a standard error message.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "break" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileBreakCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     if (parsePtr->numWords != 1) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"break\"", -1);  
         envPtr->maxStackDepth = 0;  
         return TCL_ERROR;  
     }  
   
     /*  
      * Emit a break instruction.  
      */  
   
     TclEmitOpcode(INST_BREAK, envPtr);  
     envPtr->maxStackDepth = 0;  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileCatchCmd --  
  *  
  *      Procedure called to compile the "catch" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK if  
  *      compilation was successful. If an error occurs then the  
  *      interpreter's result contains a standard error message and TCL_ERROR  
  *      is returned. If the command is too complex for TclCompileCatchCmd,  
  *      TCL_OUT_LINE_COMPILE is returned indicating that the catch command  
  *      should be compiled "out of line" by emitting code to invoke its  
  *      command procedure at runtime.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "catch" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileCatchCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     JumpFixup jumpFixup;  
     Tcl_Token *cmdTokenPtr, *nameTokenPtr;  
     char *name;  
     int localIndex, nameChars, range, maxDepth, startOffset, jumpDist;  
     int code;  
     char buffer[32 + TCL_INTEGER_SPACE];  
   
     envPtr->maxStackDepth = 0;  
     if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"catch command ?varName?\"", -1);  
         return TCL_ERROR;  
     }  
   
     /*  
      * If a variable was specified and the catch command is at global level  
      * (not in a procedure), don't compile it inline: the payoff is  
      * too small.  
      */  
   
     if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {  
         return TCL_OUT_LINE_COMPILE;  
     }  
   
     /*  
      * Make sure the variable name, if any, has no substitutions and just  
      * refers to a local scaler.  
      */  
   
     localIndex = -1;  
     cmdTokenPtr = parsePtr->tokenPtr  
             + (parsePtr->tokenPtr->numComponents + 1);  
     if (parsePtr->numWords == 3) {  
         nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);  
         if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {  
             name = nameTokenPtr[1].start;  
             nameChars = nameTokenPtr[1].size;  
             if (!TclIsLocalScalar(name, nameChars)) {  
                 return TCL_OUT_LINE_COMPILE;  
             }  
             localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,  
                     nameTokenPtr[1].size, /*create*/ 1,  
                     /*flags*/ VAR_SCALAR, envPtr->procPtr);  
         } else {  
            return TCL_OUT_LINE_COMPILE;  
         }  
     }  
   
     /*  
      * We will compile the catch command. Emit a beginCatch instruction at  
      * the start of the catch body: the subcommand it controls.  
      */  
   
     maxDepth = 0;  
       
     envPtr->exceptDepth++;  
     envPtr->maxExceptDepth =  
         TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);  
     range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);  
     TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);  
   
     startOffset = (envPtr->codeNext - envPtr->codeStart);  
     envPtr->exceptArrayPtr[range].codeOffset = startOffset;  
     code = TclCompileCmdWord(interp, cmdTokenPtr+1,  
             cmdTokenPtr->numComponents, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             sprintf(buffer, "\n    (\"catch\" body line %d)",  
                     interp->errorLine);  
             Tcl_AddObjErrorInfo(interp, buffer, -1);  
         }  
         goto done;  
     }  
     maxDepth = envPtr->maxStackDepth;  
     envPtr->exceptArrayPtr[range].numCodeBytes =  
             (envPtr->codeNext - envPtr->codeStart) - startOffset;  
                       
     /*  
      * The "no errors" epilogue code: store the body's result into the  
      * variable (if any), push "0" (TCL_OK) as the catch's "no error"  
      * result, and jump around the "error case" code.  
      */  
   
     if (localIndex != -1) {  
         if (localIndex <= 255) {  
             TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);  
         } else {  
             TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);  
         }  
     }  
     TclEmitOpcode(INST_POP, envPtr);  
     TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0),  
             envPtr);  
     if (maxDepth == 0) {  
         maxDepth = 1;  
     }  
     TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);  
   
     /*  
      * The "error case" code: store the body's result into the variable (if  
      * any), then push the error result code. The initial PC offset here is  
      * the catch's error target.  
      */  
   
     envPtr->exceptArrayPtr[range].catchOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
     if (localIndex != -1) {  
         TclEmitOpcode(INST_PUSH_RESULT, envPtr);  
         if (localIndex <= 255) {  
             TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);  
         } else {  
             TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);  
         }  
         TclEmitOpcode(INST_POP, envPtr);  
     }  
     TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);  
   
     /*  
      * Update the target of the jump after the "no errors" code, then emit  
      * an endCatch instruction at the end of the catch command.  
      */  
   
     jumpDist = (envPtr->codeNext - envPtr->codeStart)  
             - jumpFixup.codeOffset;  
     if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {  
         panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);  
     }  
     TclEmitOpcode(INST_END_CATCH, envPtr);  
   
     done:  
     envPtr->exceptDepth--;  
     envPtr->maxStackDepth = maxDepth;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileContinueCmd --  
  *  
  *      Procedure called to compile the "continue" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK unless  
  *      there was an error while parsing string. If an error occurs then  
  *      the interpreter's result contains a standard error message.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "continue" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileContinueCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     /*  
      * There should be no argument after the "continue".  
      */  
   
     if (parsePtr->numWords != 1) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"continue\"", -1);  
         envPtr->maxStackDepth = 0;  
         return TCL_ERROR;  
     }  
   
     /*  
      * Emit a continue instruction.  
      */  
   
     TclEmitOpcode(INST_CONTINUE, envPtr);  
     envPtr->maxStackDepth = 0;  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileExprCmd --  
  *  
  *      Procedure called to compile the "expr" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK  
  *      unless there was an error while parsing string. If an error occurs  
  *      then the interpreter's result contains a standard error message.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the "expr" command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "expr" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileExprCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     Tcl_Token *firstWordPtr;  
   
     envPtr->maxStackDepth = 0;  
     if (parsePtr->numWords == 1) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"expr arg ?arg ...?\"", -1);  
         return TCL_ERROR;  
     }  
   
     firstWordPtr = parsePtr->tokenPtr  
             + (parsePtr->tokenPtr->numComponents + 1);  
     return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),  
             envPtr);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileForCmd --  
  *  
  *      Procedure called to compile the "for" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK unless  
  *      there was an error while parsing string. If an error occurs then  
  *      the interpreter's result contains a standard error message.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "for" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileForCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;  
     JumpFixup jumpFalseFixup;  
     int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist;  
     int bodyRange, nextRange, code;  
     unsigned char *jumpPc;  
     char buffer[32 + TCL_INTEGER_SPACE];  
   
     envPtr->maxStackDepth = 0;  
     if (parsePtr->numWords != 5) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"for start test next command\"", -1);  
         return TCL_ERROR;  
     }  
   
     /*  
      * If the test expression requires substitutions, don't compile the for  
      * command inline. E.g., the expression might cause the loop to never  
      * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".  
      */  
   
     startTokenPtr = parsePtr->tokenPtr  
             + (parsePtr->tokenPtr->numComponents + 1);  
     testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);  
     if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {  
         return TCL_OUT_LINE_COMPILE;  
     }  
   
     /*  
      * Create ExceptionRange records for the body and the "next" command.  
      * The "next" command's ExceptionRange supports break but not continue  
      * (and has a -1 continueOffset).  
      */  
   
     envPtr->exceptDepth++;  
     envPtr->maxExceptDepth =  
             TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);  
     bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);  
     nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);  
   
     /*  
      * Inline compile the initial command.  
      */  
   
     maxDepth = 0;  
     code = TclCompileCmdWord(interp, startTokenPtr+1,  
             startTokenPtr->numComponents, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             Tcl_AddObjErrorInfo(interp,  
                     "\n    (\"for\" initial command)", -1);  
         }  
         goto done;  
     }  
     maxDepth = envPtr->maxStackDepth;  
     TclEmitOpcode(INST_POP, envPtr);  
       
     /*  
      * Compile the test then emit the conditional jump that exits the for.  
      */  
   
     testCodeOffset = (envPtr->codeNext - envPtr->codeStart);  
     code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             Tcl_AddObjErrorInfo(interp,  
                     "\n    (\"for\" test expression)", -1);  
         }  
         goto done;  
     }  
     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);  
   
     /*  
      * Compile the loop body.  
      */  
   
     nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);  
     bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);  
     envPtr->exceptArrayPtr[bodyRange].codeOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
     code = TclCompileCmdWord(interp, bodyTokenPtr+1,  
             bodyTokenPtr->numComponents, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             sprintf(buffer, "\n    (\"for\" body line %d)",  
                     interp->errorLine);  
             Tcl_AddObjErrorInfo(interp, buffer, -1);  
         }  
         goto done;  
     }  
     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
     envPtr->exceptArrayPtr[bodyRange].numCodeBytes =  
             (envPtr->codeNext - envPtr->codeStart)  
             - envPtr->exceptArrayPtr[bodyRange].codeOffset;  
     TclEmitOpcode(INST_POP, envPtr);  
   
     /*  
      * Compile the "next" subcommand.  
      */  
   
     envPtr->exceptArrayPtr[bodyRange].continueOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
     envPtr->exceptArrayPtr[nextRange].codeOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
     code = TclCompileCmdWord(interp, nextTokenPtr+1,  
             nextTokenPtr->numComponents, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             Tcl_AddObjErrorInfo(interp,  
                     "\n    (\"for\" loop-end command)", -1);  
         }  
         goto done;  
     }  
     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
     envPtr->exceptArrayPtr[nextRange].numCodeBytes =  
             (envPtr->codeNext - envPtr->codeStart)  
             - envPtr->exceptArrayPtr[nextRange].codeOffset;  
     TclEmitOpcode(INST_POP, envPtr);  
           
     /*  
      * Jump back to the test at the top of the loop. Generate a 4 byte jump  
      * if the distance to the test is > 120 bytes. This is conservative and  
      * ensures that we won't have to replace this jump if we later need to  
      * replace the ifFalse jump with a 4 byte jump.  
      */  
   
     jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);  
     jumpBackDist = (jumpBackOffset - testCodeOffset);  
     if (jumpBackDist > 120) {  
         TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);  
     } else {  
         TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);  
     }  
   
     /*  
      * Fix the target of the jumpFalse after the test.  
      */  
   
     jumpDist = (envPtr->codeNext - envPtr->codeStart)  
             - jumpFalseFixup.codeOffset;  
     if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {  
         /*  
          * Update the loop body and "next" command ExceptionRanges since  
          * they moved down.  
          */  
   
         envPtr->exceptArrayPtr[bodyRange].codeOffset += 3;  
         envPtr->exceptArrayPtr[bodyRange].continueOffset += 3;  
         envPtr->exceptArrayPtr[nextRange].codeOffset += 3;  
   
         /*  
          * Update the jump back to the test at the top of the loop since it  
          * also moved down 3 bytes.  
          */  
   
         jumpBackOffset += 3;  
         jumpPc = (envPtr->codeStart + jumpBackOffset);  
         jumpBackDist += 3;  
         if (jumpBackDist > 120) {  
             TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);  
         } else {  
             TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);  
         }  
     }  
       
     /*  
      * Set the loop's break target.  
      */  
   
     envPtr->exceptArrayPtr[bodyRange].breakOffset =  
             envPtr->exceptArrayPtr[nextRange].breakOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
       
     /*  
      * The for command's result is an empty string.  
      */  
   
     TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);  
     if (maxDepth == 0) {  
         maxDepth = 1;  
     }  
     code = TCL_OK;  
   
     done:  
     envPtr->maxStackDepth = maxDepth;  
     envPtr->exceptDepth--;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileForeachCmd --  
  *  
  *      Procedure called to compile the "foreach" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK if  
  *      compilation was successful. If an error occurs then the  
  *      interpreter's result contains a standard error message and TCL_ERROR  
  *      is returned. If the command is too complex for TclCompileForeachCmd,  
  *      TCL_OUT_LINE_COMPILE is returned indicating that the foreach command  
  *      should be compiled "out of line" by emitting code to invoke its  
  *      command procedure at runtime.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the "while" command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "foreach" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileForeachCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     Proc *procPtr = envPtr->procPtr;  
     ForeachInfo *infoPtr;       /* Points to the structure describing this  
                                  * foreach command. Stored in a AuxData  
                                  * record in the ByteCode. */  
     int firstValueTemp;         /* Index of the first temp var in the frame  
                                  * used to point to a value list. */  
     int loopCtTemp;             /* Index of temp var holding the loop's  
                                  * iteration count. */  
     Tcl_Token *tokenPtr, *bodyTokenPtr;  
     char *varList;  
     unsigned char *jumpPc;  
     JumpFixup jumpFalseFixup;  
     int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range;  
     int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;  
     char savedChar;  
     char buffer[32 + TCL_INTEGER_SPACE];  
   
     /*  
      * We parse the variable list argument words and create two arrays:  
      *    varcList[i] is number of variables in i-th var list  
      *    varvList[i] points to array of var names in i-th var list  
      */  
   
 #define STATIC_VAR_LIST_SIZE 5  
     int varcListStaticSpace[STATIC_VAR_LIST_SIZE];  
     char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];  
     int *varcList = varcListStaticSpace;  
     char ***varvList = varvListStaticSpace;  
   
     /*  
      * If the foreach command isn't in a procedure, don't compile it inline:  
      * the payoff is too small.  
      */  
   
     envPtr->maxStackDepth = 0;  
     if (procPtr == NULL) {  
         return TCL_OUT_LINE_COMPILE;  
     }  
   
     maxDepth = 0;  
       
     numWords = parsePtr->numWords;  
     if ((numWords < 4) || (numWords%2 != 0)) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);  
         return TCL_ERROR;  
     }  
   
     /*  
      * Allocate storage for the varcList and varvList arrays if necessary.  
      */  
   
     numLists = (numWords - 2)/2;  
     if (numLists > STATIC_VAR_LIST_SIZE) {  
         varcList = (int *) ckalloc(numLists * sizeof(int));  
         varvList = (char ***) ckalloc(numLists * sizeof(char **));  
     }  
     for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {  
         varcList[loopIndex] = 0;  
         varvList[loopIndex] = (char **) NULL;  
     }  
       
     /*  
      * Set the exception stack depth.  
      */  
   
     envPtr->exceptDepth++;  
     envPtr->maxExceptDepth =  
         TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);  
   
     /*  
      * Break up each var list and set the varcList and varvList arrays.  
      * Don't compile the foreach inline if any var name needs substitutions  
      * or isn't a scalar, or if any var list needs substitutions.  
      */  
   
     loopIndex = 0;  
     for (i = 0, tokenPtr = parsePtr->tokenPtr;  
             i < numWords-1;  
             i++, tokenPtr += (tokenPtr->numComponents + 1)) {  
         if (i%2 == 1) {  
             if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {  
                 code = TCL_OUT_LINE_COMPILE;  
                 goto done;  
             }  
             varList = tokenPtr[1].start;  
             savedChar = varList[tokenPtr[1].size];  
   
             /*  
              * Note there is a danger that modifying the string could have  
              * undesirable side effects.  In this case, Tcl_SplitList does  
              * not have any dependencies on shared strings so we should be  
              * safe.  
              */  
   
             varList[tokenPtr[1].size] = '\0';  
             code = Tcl_SplitList(interp, varList,  
                     &varcList[loopIndex], &varvList[loopIndex]);  
             varList[tokenPtr[1].size] = savedChar;  
             if (code != TCL_OK) {  
                 goto done;  
             }  
   
             numVars = varcList[loopIndex];  
             for (j = 0;  j < numVars;  j++) {  
                 char *varName = varvList[loopIndex][j];  
                 if (!TclIsLocalScalar(varName, (int) strlen(varName))) {  
                     code = TCL_OUT_LINE_COMPILE;  
                     goto done;  
                 }  
             }  
             loopIndex++;  
         }  
     }  
   
     /*  
      * We will compile the foreach command.  
      * Reserve (numLists + 1) temporary variables:  
      *    - numLists temps to hold each value list  
      *    - 1 temp for the loop counter (index of next element in each list)  
      * At this time we don't try to reuse temporaries; if there are two  
      * nonoverlapping foreach loops, they don't share any temps.  
      */  
   
     firstValueTemp = -1;  
     for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {  
         tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,  
                 /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);  
         if (loopIndex == 0) {  
             firstValueTemp = tempVar;  
         }  
     }  
     loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,  
             /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);  
       
     /*  
      * Create and initialize the ForeachInfo and ForeachVarList data  
      * structures describing this command. Then create a AuxData record  
      * pointing to the ForeachInfo structure.  
      */  
   
     infoPtr = (ForeachInfo *) ckalloc((unsigned)  
             (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));  
     infoPtr->numLists = numLists;  
     infoPtr->firstValueTemp = firstValueTemp;  
     infoPtr->loopCtTemp = loopCtTemp;  
     for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {  
         ForeachVarList *varListPtr;  
         numVars = varcList[loopIndex];  
         varListPtr = (ForeachVarList *) ckalloc((unsigned)  
                 sizeof(ForeachVarList) + (numVars * sizeof(int)));  
         varListPtr->numVars = numVars;  
         for (j = 0;  j < numVars;  j++) {  
             char *varName = varvList[loopIndex][j];  
             int nameChars = strlen(varName);  
             varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,  
                     nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);  
         }  
         infoPtr->varLists[loopIndex] = varListPtr;  
     }  
     infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);  
   
     /*  
      * Evaluate then store each value list in the associated temporary.  
      */  
   
     range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);  
       
     loopIndex = 0;  
     for (i = 0, tokenPtr = parsePtr->tokenPtr;  
             i < numWords-1;  
             i++, tokenPtr += (tokenPtr->numComponents + 1)) {  
         if ((i%2 == 0) && (i > 0)) {  
             code = TclCompileTokens(interp, tokenPtr+1,  
                     tokenPtr->numComponents, envPtr);  
             if (code != TCL_OK) {  
                 goto done;  
             }  
             maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
   
             tempVar = (firstValueTemp + loopIndex);  
             if (tempVar <= 255) {  
                 TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);  
             } else {  
                 TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);  
             }  
             TclEmitOpcode(INST_POP, envPtr);  
             loopIndex++;  
         }  
     }  
     bodyTokenPtr = tokenPtr;  
   
     /*  
      * Initialize the temporary var that holds the count of loop iterations.  
      */  
   
     TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);  
       
     /*  
      * Top of loop code: assign each loop variable and check whether  
      * to terminate the loop.  
      */  
   
     envPtr->exceptArrayPtr[range].continueOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
     TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);  
     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);  
       
     /*  
      * Inline compile the loop body.  
      */  
   
     envPtr->exceptArrayPtr[range].codeOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
     code = TclCompileCmdWord(interp, bodyTokenPtr+1,  
             bodyTokenPtr->numComponents, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             sprintf(buffer, "\n    (\"foreach\" body line %d)",  
                     interp->errorLine);  
             Tcl_AddObjErrorInfo(interp, buffer, -1);  
         }  
         goto done;  
     }  
     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
     envPtr->exceptArrayPtr[range].numCodeBytes =  
             (envPtr->codeNext - envPtr->codeStart)  
             - envPtr->exceptArrayPtr[range].codeOffset;  
     TclEmitOpcode(INST_POP, envPtr);  
           
     /*  
      * Jump back to the test at the top of the loop. Generate a 4 byte jump  
      * if the distance to the test is > 120 bytes. This is conservative and  
      * ensures that we won't have to replace this jump if we later need to  
      * replace the ifFalse jump with a 4 byte jump.  
      */  
   
     jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);  
     jumpBackDist =  
         (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);  
     if (jumpBackDist > 120) {  
         TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);  
     } else {  
         TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);  
     }  
   
     /*  
      * Fix the target of the jump after the foreach_step test.  
      */  
   
     jumpDist = (envPtr->codeNext - envPtr->codeStart)  
             - jumpFalseFixup.codeOffset;  
     if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {  
         /*  
          * Update the loop body's starting PC offset since it moved down.  
          */  
   
         envPtr->exceptArrayPtr[range].codeOffset += 3;  
   
         /*  
          * Update the jump back to the test at the top of the loop since it  
          * also moved down 3 bytes.  
          */  
   
         jumpBackOffset += 3;  
         jumpPc = (envPtr->codeStart + jumpBackOffset);  
         jumpBackDist += 3;  
         if (jumpBackDist > 120) {  
             TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);  
         } else {  
             TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);  
         }  
     }  
   
     /*  
      * Set the loop's break target.  
      */  
   
     envPtr->exceptArrayPtr[range].breakOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
       
     /*  
      * The foreach command's result is an empty string.  
      */  
   
     TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);  
     if (maxDepth == 0) {  
         maxDepth = 1;  
     }  
   
     done:  
     for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {  
         if (varvList[loopIndex] != (char **) NULL) {  
             ckfree((char *) varvList[loopIndex]);  
         }  
     }  
     if (varcList != varcListStaticSpace) {  
         ckfree((char *) varcList);  
         ckfree((char *) varvList);  
     }  
     envPtr->maxStackDepth = maxDepth;  
     envPtr->exceptDepth--;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * DupForeachInfo --  
  *  
  *      This procedure duplicates a ForeachInfo structure created as  
  *      auxiliary data during the compilation of a foreach command.  
  *  
  * Results:  
  *      A pointer to a newly allocated copy of the existing ForeachInfo  
  *      structure is returned.  
  *  
  * Side effects:  
  *      Storage for the copied ForeachInfo record is allocated. If the  
  *      original ForeachInfo structure pointed to any ForeachVarList  
  *      records, these structures are also copied and pointers to them  
  *      are stored in the new ForeachInfo record.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static ClientData  
 DupForeachInfo(clientData)  
     ClientData clientData;      /* The foreach command's compilation  
                                  * auxiliary data to duplicate. */  
 {  
     register ForeachInfo *srcPtr = (ForeachInfo *) clientData;  
     ForeachInfo *dupPtr;  
     register ForeachVarList *srcListPtr, *dupListPtr;  
     int numLists = srcPtr->numLists;  
     int numVars, i, j;  
       
     dupPtr = (ForeachInfo *) ckalloc((unsigned)  
             (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));  
     dupPtr->numLists = numLists;  
     dupPtr->firstValueTemp = srcPtr->firstValueTemp;  
     dupPtr->loopCtTemp = srcPtr->loopCtTemp;  
       
     for (i = 0;  i < numLists;  i++) {  
         srcListPtr = srcPtr->varLists[i];  
         numVars = srcListPtr->numVars;  
         dupListPtr = (ForeachVarList *) ckalloc((unsigned)  
                 sizeof(ForeachVarList) + numVars*sizeof(int));  
         dupListPtr->numVars = numVars;  
         for (j = 0;  j < numVars;  j++) {  
             dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];  
         }  
         dupPtr->varLists[i] = dupListPtr;  
     }  
     return (ClientData) dupPtr;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * FreeForeachInfo --  
  *  
  *      Procedure to free a ForeachInfo structure created as auxiliary data  
  *      during the compilation of a foreach command.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Storage for the ForeachInfo structure pointed to by the ClientData  
  *      argument is freed as is any ForeachVarList record pointed to by the  
  *      ForeachInfo structure.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 FreeForeachInfo(clientData)  
     ClientData clientData;      /* The foreach command's compilation  
                                  * auxiliary data to free. */  
 {  
     register ForeachInfo *infoPtr = (ForeachInfo *) clientData;  
     register ForeachVarList *listPtr;  
     int numLists = infoPtr->numLists;  
     register int i;  
   
     for (i = 0;  i < numLists;  i++) {  
         listPtr = infoPtr->varLists[i];  
         ckfree((char *) listPtr);  
     }  
     ckfree((char *) infoPtr);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileIfCmd --  
  *  
  *      Procedure called to compile the "if" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK if  
  *      compilation was successful. If an error occurs then the  
  *      interpreter's result contains a standard error message and TCL_ERROR  
  *      is returned. If the command is too complex for TclCompileIfCmd,  
  *      TCL_OUT_LINE_COMPILE is returned indicating that the if command  
  *      should be compiled "out of line" by emitting code to invoke its  
  *      command procedure at runtime.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "if" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileIfCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     JumpFixupArray jumpFalseFixupArray;  
                                 /* Used to fix the ifFalse jump after each  
                                  * test when its target PC is determined. */  
     JumpFixupArray jumpEndFixupArray;  
                                 /* Used to fix the jump after each "then"  
                                  * body to the end of the "if" when that PC  
                                  * is determined. */  
     Tcl_Token *tokenPtr, *testTokenPtr;  
     int jumpDist, jumpFalseDist, jumpIndex;  
     int numWords, wordIdx, numBytes, maxDepth, j, code;  
     char *word;  
     char buffer[100];  
   
     TclInitJumpFixupArray(&jumpFalseFixupArray);  
     TclInitJumpFixupArray(&jumpEndFixupArray);  
     maxDepth = 0;  
     code = TCL_OK;  
   
     /*  
      * Each iteration of this loop compiles one "if expr ?then? body"  
      * or "elseif expr ?then? body" clause.  
      */  
   
     tokenPtr = parsePtr->tokenPtr;  
     wordIdx = 0;  
     numWords = parsePtr->numWords;  
     while (wordIdx < numWords) {  
         /*  
          * Stop looping if the token isn't "if" or "elseif".  
          */  
   
         if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {  
             break;  
         }  
         word = tokenPtr[1].start;  
         numBytes = tokenPtr[1].size;  
         if ((tokenPtr == parsePtr->tokenPtr)  
                 || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {  
             tokenPtr += (tokenPtr->numComponents + 1);  
             wordIdx++;  
         } else {  
             break;  
         }  
         if (wordIdx >= numWords) {  
             sprintf(buffer,  
                     "wrong # args: no expression after \"%.30s\" argument",  
                     word);  
             Tcl_ResetResult(interp);  
             Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);  
             code = TCL_ERROR;  
             goto done;  
         }  
   
         /*  
          * Compile the test expression then emit the conditional jump  
          * around the "then" part. If the expression word isn't simple,  
          * we back off and compile the if command out-of-line.  
          */  
           
         testTokenPtr = tokenPtr;  
         code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);  
         if (code != TCL_OK) {  
             if (code == TCL_ERROR) {  
                 Tcl_AddObjErrorInfo(interp,  
                         "\n    (\"if\" test expression)", -1);  
             }  
             goto done;  
         }  
         maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
         if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {  
             TclExpandJumpFixupArray(&jumpFalseFixupArray);  
         }  
         jumpIndex = jumpFalseFixupArray.next;  
         jumpFalseFixupArray.next++;  
         TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,  
                 &(jumpFalseFixupArray.fixup[jumpIndex]));  
           
         /*  
          * Skip over the optional "then" before the then clause.  
          */  
   
         tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);  
         wordIdx++;  
         if (wordIdx >= numWords) {  
             sprintf(buffer, "wrong # args: no script following \"%.20s\" argument", testTokenPtr->start);  
             Tcl_ResetResult(interp);  
             Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);  
             code = TCL_ERROR;  
             goto done;  
         }  
         if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {  
             word = tokenPtr[1].start;  
             numBytes = tokenPtr[1].size;  
             if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {  
                 tokenPtr += (tokenPtr->numComponents + 1);  
                 wordIdx++;  
                 if (wordIdx >= numWords) {  
                     Tcl_ResetResult(interp);  
                     Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                             "wrong # args: no script following \"then\" argument", -1);  
                     code = TCL_ERROR;  
                     goto done;  
                 }  
             }  
         }  
   
         /*  
          * Compile the "then" command body.  
          */  
   
         code = TclCompileCmdWord(interp, tokenPtr+1,  
                 tokenPtr->numComponents, envPtr);  
         if (code != TCL_OK) {  
             if (code == TCL_ERROR) {  
                 sprintf(buffer, "\n    (\"if\" then script line %d)",  
                         interp->errorLine);  
                 Tcl_AddObjErrorInfo(interp, buffer, -1);  
             }  
             goto done;  
         }  
         maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
   
         /*  
          * Jump to the end of the "if" command. Both jumpFalseFixupArray and  
          * jumpEndFixupArray are indexed by "jumpIndex".  
          */  
   
         if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {  
             TclExpandJumpFixupArray(&jumpEndFixupArray);  
         }  
         jumpEndFixupArray.next++;  
         TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,  
                 &(jumpEndFixupArray.fixup[jumpIndex]));  
   
         /*  
          * Fix the target of the jumpFalse after the test. Generate a 4 byte  
          * jump if the distance is > 120 bytes. This is conservative, and  
          * ensures that we won't have to replace this jump if we later also  
          * need to replace the proceeding jump to the end of the "if" with a  
          * 4 byte jump.  
          */  
   
         jumpDist = (envPtr->codeNext - envPtr->codeStart)  
                 - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;  
         if (TclFixupForwardJump(envPtr,  
                 &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {  
             /*  
              * Adjust the code offset for the proceeding jump to the end  
              * of the "if" command.  
              */  
   
             jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;  
         }  
   
         tokenPtr += (tokenPtr->numComponents + 1);  
         wordIdx++;  
     }  
   
     /*  
      * Check for the optional else clause.  
      */  
   
     if ((wordIdx < numWords)  
             && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {  
         /*  
          * There is an else clause. Skip over the optional "else" word.  
          */  
           
         word = tokenPtr[1].start;  
         numBytes = tokenPtr[1].size;  
         if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {  
             tokenPtr += (tokenPtr->numComponents + 1);  
             wordIdx++;  
             if (wordIdx >= numWords) {  
                 Tcl_ResetResult(interp);  
                 Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                         "wrong # args: no script following \"else\" argument", -1);  
                 code = TCL_ERROR;  
                 goto done;  
             }  
         }  
   
         /*  
          * Compile the else command body.  
          */  
           
         code = TclCompileCmdWord(interp, tokenPtr+1,  
                 tokenPtr->numComponents, envPtr);  
         if (code != TCL_OK) {  
             if (code == TCL_ERROR) {  
                 sprintf(buffer, "\n    (\"if\" else script line %d)",  
                         interp->errorLine);  
                 Tcl_AddObjErrorInfo(interp, buffer, -1);  
             }  
             goto done;  
         }  
         maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
   
         /*  
          * Make sure there are no words after the else clause.  
          */  
           
         wordIdx++;  
         if (wordIdx < numWords) {  
             Tcl_ResetResult(interp);  
             Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                     "wrong # args: extra words after \"else\" clause in \"if\" command", -1);  
             code = TCL_ERROR;  
             goto done;  
         }  
     } else {  
         /*  
          * No else clause: the "if" command's result is an empty string.  
          */  
   
         TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr);  
         maxDepth = TclMax(1, maxDepth);  
     }  
   
     /*  
      * Fix the unconditional jumps to the end of the "if" command.  
      */  
       
     for (j = jumpEndFixupArray.next;  j > 0;  j--) {  
         jumpIndex = (j - 1);    /* i.e. process the closest jump first */  
         jumpDist = (envPtr->codeNext - envPtr->codeStart)  
                 - jumpEndFixupArray.fixup[jumpIndex].codeOffset;  
         if (TclFixupForwardJump(envPtr,  
                 &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {  
             /*  
              * Adjust the immediately preceeding "ifFalse" jump. We moved  
              * it's target (just after this jump) down three bytes.  
              */  
   
             unsigned char *ifFalsePc = envPtr->codeStart  
                     + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;  
             unsigned char opCode = *ifFalsePc;  
             if (opCode == INST_JUMP_FALSE1) {  
                 jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);  
                 jumpFalseDist += 3;  
                 TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));  
             } else if (opCode == INST_JUMP_FALSE4) {  
                 jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);  
                 jumpFalseDist += 3;  
                 TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));  
             } else {  
                 panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");  
             }  
         }  
     }  
           
     /*  
      * Free the jumpFixupArray array if malloc'ed storage was used.  
      */  
   
     done:  
     TclFreeJumpFixupArray(&jumpFalseFixupArray);  
     TclFreeJumpFixupArray(&jumpEndFixupArray);  
     envPtr->maxStackDepth = maxDepth;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileIncrCmd --  
  *  
  *      Procedure called to compile the "incr" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK if  
  *      compilation was successful. If an error occurs then the  
  *      interpreter's result contains a standard error message and TCL_ERROR  
  *      is returned. If the command is too complex for TclCompileIncrCmd,  
  *      TCL_OUT_LINE_COMPILE is returned indicating that the incr command  
  *      should be compiled "out of line" by emitting code to invoke its  
  *      command procedure at runtime.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the "incr" command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "incr" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileIncrCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     Tcl_Token *varTokenPtr, *incrTokenPtr;  
     Tcl_Parse elemParse;  
     int gotElemParse = 0;  
     char *name, *elName, *p;  
     int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code;  
     int maxDepth = 0;  
     char buffer[160];  
   
     envPtr->maxStackDepth = 0;  
     if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"incr varName ?increment?\"", -1);  
         return TCL_ERROR;  
     }  
       
     name = NULL;  
     elName = NULL;  
     elNameChars = 0;  
     localIndex = -1;  
     code = TCL_OK;  
   
     varTokenPtr = parsePtr->tokenPtr  
             + (parsePtr->tokenPtr->numComponents + 1);  
     /*  
      * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether  
      * curly braces surround the variable name.  
      * This really matters for array elements to handle things like  
      *    set {x($foo)} 5  
      * which raises an undefined var error if we are not careful here.  
      * This goes with the hack in TclCompileSetCmd.  
      */  
     if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&  
             (varTokenPtr->start[0] != '{')) {  
         /*  
          * A simple variable name. Divide it up into "name" and "elName"  
          * strings. If it is not a local variable, look it up at runtime.  
          */  
           
         name = varTokenPtr[1].start;  
         nameChars = varTokenPtr[1].size;  
         for (i = 0, p = name;  i < nameChars;  i++, p++) {  
             if (*p == '(') {  
                 char *openParen = p;  
                 p = (name + nameChars-1);        
                 if (*p == ')') { /* last char is ')' => array reference */  
                     nameChars = (openParen - name);  
                     elName = openParen+1;  
                     elNameChars = (p - elName);  
                 }  
                 break;  
             }  
         }  
         if (envPtr->procPtr != NULL) {  
             localIndex = TclFindCompiledLocal(name, nameChars,  
                     /*create*/ 0, /*flags*/ 0, envPtr->procPtr);  
             if (localIndex > 255) {           /* we'll push the name */  
                 localIndex = -1;  
             }  
         }  
         if (localIndex < 0) {  
             TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,  
                         /*onHeap*/ 0), envPtr);  
             maxDepth = 1;  
         }  
   
         /*  
          * Compile the element script, if any.  
          */  
           
         if (elName != NULL) {  
             /*  
              * Temporarily replace the '(' and ')' by '"'s.  
              */  
               
             *(elName-1) = '"';  
             *(elName+elNameChars) = '"';  
             code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,  
                     /*nested*/ 0, &elemParse);  
             *(elName-1) = '(';  
             *(elName+elNameChars) = ')';  
             gotElemParse = 1;  
             if ((code != TCL_OK) || (elemParse.numWords > 1)) {  
                 sprintf(buffer, "\n    (parsing index for array \"%.*s\")",  
                         TclMin(nameChars, 100), name);  
                 Tcl_AddObjErrorInfo(interp, buffer, -1);  
                 code = TCL_ERROR;  
                 goto done;  
             } else if (elemParse.numWords == 1) {  
                 code = TclCompileTokens(interp, elemParse.tokenPtr+1,  
                         elemParse.tokenPtr->numComponents, envPtr);  
                 if (code != TCL_OK) {  
                     goto done;  
                 }  
                 maxDepth += envPtr->maxStackDepth;  
             } else {  
                 TclEmitPush(TclRegisterLiteral(envPtr, "", 0,  
                         /*alreadyAlloced*/ 0), envPtr);  
                 maxDepth += 1;  
             }  
         }  
     } else {  
         /*  
          * Not a simple variable name. Look it up at runtime.  
          */  
           
         code = TclCompileTokens(interp, varTokenPtr+1,  
                 varTokenPtr->numComponents, envPtr);  
         if (code != TCL_OK) {  
             goto done;  
         }  
         maxDepth = envPtr->maxStackDepth;  
     }  
       
     /*  
      * If an increment is given, push it, but see first if it's a small  
      * integer.  
      */  
   
     haveImmValue = 0;  
     immValue = 0;  
     if (parsePtr->numWords == 3) {  
         incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);  
         if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {  
             char *word = incrTokenPtr[1].start;  
             int numBytes = incrTokenPtr[1].size;  
             char savedChar = word[numBytes];  
             long n;  
           
             /*  
              * Note there is a danger that modifying the string could have  
              * undesirable side effects.  In this case, TclLooksLikeInt and  
              * TclGetLong do not have any dependencies on shared strings so we  
              * should be safe.  
              */  
   
             word[numBytes] = '\0';  
             if (TclLooksLikeInt(word, numBytes)  
                     && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) {  
                 if ((-127 <= n) && (n <= 127)) {  
                     haveImmValue = 1;  
                     immValue = n;  
                 }  
             }  
             word[numBytes] = savedChar;  
             if (!haveImmValue) {  
                 TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes,  
                        /*onHeap*/ 0), envPtr);  
                 maxDepth += 1;  
             }  
         } else {  
             code = TclCompileTokens(interp, incrTokenPtr+1,  
                     incrTokenPtr->numComponents, envPtr);  
             if (code != TCL_OK) {  
                 if (code == TCL_ERROR) {  
                     Tcl_AddObjErrorInfo(interp,  
                             "\n    (increment expression)", -1);  
                 }  
                 goto done;  
             }  
             maxDepth += envPtr->maxStackDepth;  
         }  
     } else {                    /* no incr amount given so use 1 */  
         haveImmValue = 1;  
         immValue = 1;  
     }  
       
     /*  
      * Emit the instruction to increment the variable.  
      */  
   
     if (name != NULL) {  
         if (elName == NULL) {  
             if (localIndex >= 0) {  
                 if (haveImmValue) {  
                     TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex,  
                                     envPtr);  
                     TclEmitInt1(immValue, envPtr);  
                 } else {  
                     TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);  
                 }  
             } else {  
                 if (haveImmValue) {  
                     TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue,  
                                    envPtr);  
                 } else {  
                     TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);  
                 }  
             }  
         } else {  
             if (localIndex >= 0) {  
                 if (haveImmValue) {  
                     TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex,  
                                     envPtr);  
                     TclEmitInt1(immValue, envPtr);  
                 } else {  
                     TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);  
                 }  
             } else {  
                 if (haveImmValue) {  
                     TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue,  
                                    envPtr);  
                 } else {  
                     TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);  
                 }  
             }  
         }  
     } else {                    /* non-simple variable name */  
         if (haveImmValue) {  
             TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);  
         } else {  
             TclEmitOpcode(INST_INCR_STK, envPtr);  
         }  
     }  
           
     done:  
     if (gotElemParse) {  
         Tcl_FreeParse(&elemParse);  
     }  
     envPtr->maxStackDepth = maxDepth;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileSetCmd --  
  *  
  *      Procedure called to compile the "set" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is normally TCL_OK  
  *      unless there was an error while parsing string. If an error occurs  
  *      then the interpreter's result contains a standard error message. If  
  *      complation fails because the set command requires a second level of  
  *      substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the  
  *      set command should be compiled "out of line" by emitting code to  
  *      invoke its command procedure (Tcl_SetCmd) at runtime.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the incr command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "set" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileSetCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     Tcl_Token *varTokenPtr, *valueTokenPtr;  
     Tcl_Parse elemParse;  
     int gotElemParse = 0;  
     register char *p;  
     char *name, *elName;  
     int nameChars, elNameChars;  
     register int i, n;  
     int isAssignment, simpleVarName, localIndex, numWords;  
     int maxDepth = 0;  
     int code = TCL_OK;  
   
     envPtr->maxStackDepth = 0;  
     numWords = parsePtr->numWords;  
     if ((numWords != 2) && (numWords != 3)) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"set varName ?newValue?\"", -1);  
         return TCL_ERROR;  
     }  
     isAssignment = (numWords == 3);  
   
     /*  
      * Decide if we can use a frame slot for the var/array name or if we  
      * need to emit code to compute and push the name at runtime. We use a  
      * frame slot (entry in the array of local vars) if we are compiling a  
      * procedure body and if the name is simple text that does not include  
      * namespace qualifiers.  
      */  
   
     simpleVarName = 0;  
     name = elName = NULL;  
     nameChars = elNameChars = 0;  
     localIndex = -1;  
   
     varTokenPtr = parsePtr->tokenPtr  
             + (parsePtr->tokenPtr->numComponents + 1);  
     /*  
      * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether  
      * curly braces surround the variable name.  
      * This really matters for array elements to handle things like  
      *    set {x($foo)} 5  
      * which raises an undefined var error if we are not careful here.  
      * This goes with the hack in TclCompileIncrCmd.  
      */  
     if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&  
             (varTokenPtr->start[0] != '{')) {  
         simpleVarName = 1;  
   
         name = varTokenPtr[1].start;  
         nameChars = varTokenPtr[1].size;  
         /* last char is ')' => potential array reference */  
         if ( *(name + nameChars - 1) == ')') {  
             for (i = 0, p = name;  i < nameChars;  i++, p++) {  
                 if (*p == '(') {  
                     elName = p + 1;  
                     elNameChars = nameChars - i - 2;  
                     nameChars = i ;  
                     break;  
                 }  
             }  
         }  
   
         /*  
          * If elName contains any double quotes ("), we can't inline  
          * compile the element script using the replace '()' by '"'  
          * technique below.  
          */  
   
         for (i = 0, p = elName;  i < elNameChars;  i++, p++) {  
             if (*p == '"') {  
                 simpleVarName = 0;  
                 break;  
             }  
         }  
     } else if (((n = varTokenPtr->numComponents) > 1)  
             && (varTokenPtr[1].type == TCL_TOKEN_TEXT)  
             && (varTokenPtr[n].type == TCL_TOKEN_TEXT)  
             && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {  
         simpleVarName = 0;  
   
         /*  
          * Check for parentheses inside first token  
          */  
         for (i = 0, p = varTokenPtr[1].start;  
              i < varTokenPtr[1].size; i++, p++) {  
             if (*p == '(') {  
                 simpleVarName = 1;  
                 break;  
             }  
         }  
         if (simpleVarName) {  
             name = varTokenPtr[1].start;  
             nameChars = p - varTokenPtr[1].start;  
             elName = p + 1;  
             elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;  
   
             /*  
              * If elName contains any double quotes ("), we can't inline  
              * compile the element script using the replace '()' by '"'  
              * technique below.  
              */  
   
             for (i = 0, p = elName;  i < elNameChars;  i++, p++) {  
                 if (*p == '"') {  
                     simpleVarName = 0;  
                     break;  
                 }  
             }  
         }  
     }  
   
     if (simpleVarName) {  
         /*  
          * See whether name has any namespace separators (::'s).  
          */  
   
         int hasNsQualifiers = 0;  
         for (i = 0, p = name;  i < nameChars;  i++, p++) {  
             if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {  
                 hasNsQualifiers = 1;  
                 break;  
             }  
         }  
           
         /*  
          * Look up the var name's index in the array of local vars in the  
          * proc frame. If retrieving the var's value and it doesn't already  
          * exist, push its name and look it up at runtime.  
          */  
   
         if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {  
             localIndex = TclFindCompiledLocal(name, nameChars,  
                     /*create*/ isAssignment,  
                     /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),  
                     envPtr->procPtr);  
         }  
         if (localIndex >= 0) {  
             maxDepth = 0;  
         } else {  
             TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,  
                     /*onHeap*/ 0), envPtr);  
             maxDepth = 1;  
         }  
   
         /*  
          * Compile the element script, if any.  
          */  
           
         if (elName != NULL) {  
             /*  
              * Temporarily replace the '(' and ')' by '"'s.  
              */  
   
             *(elName-1) = '"';  
             *(elName+elNameChars) = '"';  
             code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,  
                     /*nested*/ 0, &elemParse);  
             *(elName-1) = '(';  
             *(elName+elNameChars) = ')';  
             gotElemParse = 1;  
             if ((code != TCL_OK) || (elemParse.numWords > 1)) {  
                 char buffer[160];  
                 sprintf(buffer, "\n    (parsing index for array \"%.*s\")",  
                         TclMin(nameChars, 100), name);  
                 Tcl_AddObjErrorInfo(interp, buffer, -1);  
                 code = TCL_ERROR;  
                 goto done;  
             } else if (elemParse.numWords == 1) {  
                 code = TclCompileTokens(interp, elemParse.tokenPtr+1,  
                         elemParse.tokenPtr->numComponents, envPtr);  
                 if (code != TCL_OK) {  
                     goto done;  
                 }  
                 maxDepth += envPtr->maxStackDepth;  
             } else {  
                 TclEmitPush(TclRegisterLiteral(envPtr, "", 0,  
                         /*alreadyAlloced*/ 0), envPtr);  
                 maxDepth += 1;  
             }  
         }  
     } else {  
         /*  
          * The var name isn't simple: compile and push it.  
          */  
   
         code = TclCompileTokens(interp, varTokenPtr+1,  
                 varTokenPtr->numComponents, envPtr);  
         if (code != TCL_OK) {  
             goto done;  
         }  
         maxDepth += envPtr->maxStackDepth;  
     }  
           
     /*  
      * If we are doing an assignment, push the new value.  
      */  
       
     if (isAssignment) {  
         valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);  
         if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {  
             TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start,  
                     valueTokenPtr[1].size, /*onHeap*/ 0), envPtr);  
             maxDepth += 1;  
         } else {  
             code = TclCompileTokens(interp, valueTokenPtr+1,  
                     valueTokenPtr->numComponents, envPtr);  
             if (code != TCL_OK) {  
                 goto done;  
             }  
             maxDepth += envPtr->maxStackDepth;  
         }  
     }  
           
     /*  
      * Emit instructions to set/get the variable.  
      */  
   
     if (simpleVarName) {  
         if (elName == NULL) {  
             if (localIndex >= 0) {  
                 if (localIndex <= 255) {  
                     TclEmitInstInt1((isAssignment?  
                             INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),  
                             localIndex, envPtr);  
                 } else {  
                     TclEmitInstInt4((isAssignment?  
                             INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),  
                             localIndex, envPtr);  
                 }  
             } else {  
                 TclEmitOpcode((isAssignment?  
                         INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),  
                         envPtr);  
             }  
         } else {  
             if (localIndex >= 0) {  
                 if (localIndex <= 255) {  
                     TclEmitInstInt1((isAssignment?  
                             INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),  
                             localIndex, envPtr);  
                 } else {  
                     TclEmitInstInt4((isAssignment?  
                             INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),  
                             localIndex, envPtr);  
                 }  
             } else {  
                 TclEmitOpcode((isAssignment?  
                         INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),  
                         envPtr);  
             }  
         }  
     } else {  
         TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK),  
                 envPtr);  
     }  
           
     done:  
     if (gotElemParse) {  
         Tcl_FreeParse(&elemParse);  
     }  
     envPtr->maxStackDepth = maxDepth;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileWhileCmd --  
  *  
  *      Procedure called to compile the "while" command.  
  *  
  * Results:  
  *      The return value is a standard Tcl result, which is TCL_OK if  
  *      compilation was successful. If an error occurs then the  
  *      interpreter's result contains a standard error message and TCL_ERROR  
  *      is returned. If compilation failed because the command is too  
  *      complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned  
  *      indicating that the while command should be compiled "out of line"  
  *      by emitting code to invoke its command procedure at runtime.  
  *  
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the "while" command.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the "while" command  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileWhileCmd(interp, parsePtr, envPtr)  
     Tcl_Interp *interp;         /* Used for error reporting. */  
     Tcl_Parse *parsePtr;        /* Points to a parse structure for the  
                                  * command created by Tcl_ParseCommand. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     Tcl_Token *testTokenPtr, *bodyTokenPtr;  
     JumpFixup jumpFalseFixup;  
     unsigned char *jumpPc;  
     int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset;  
     int range, maxDepth, code;  
     char buffer[32 + TCL_INTEGER_SPACE];  
   
     envPtr->maxStackDepth = 0;  
     maxDepth = 0;  
     if (parsePtr->numWords != 3) {  
         Tcl_ResetResult(interp);  
         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
                 "wrong # args: should be \"while test command\"", -1);  
         return TCL_ERROR;  
     }  
   
     /*  
      * If the test expression requires substitutions, don't compile the  
      * while command inline. E.g., the expression might cause the loop to  
      * never execute or execute forever, as in "while "$x < 5" {}".  
      */  
   
     testTokenPtr = parsePtr->tokenPtr  
             + (parsePtr->tokenPtr->numComponents + 1);  
     if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {  
         return TCL_OUT_LINE_COMPILE;  
     }  
   
     /*  
      * Create a ExceptionRange record for the loop body. This is used to  
      * implement break and continue.  
      */  
   
     envPtr->exceptDepth++;  
     envPtr->maxExceptDepth =  
         TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);  
     range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);  
     envPtr->exceptArrayPtr[range].continueOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
   
     /*  
      * Compile the test expression then emit the conditional jump that  
      * terminates the while. We already know it's a simple word.  
      */  
   
     testCodeOffset = (envPtr->codeNext - envPtr->codeStart);  
     envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;  
     code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             Tcl_AddObjErrorInfo(interp,  
                     "\n    (\"while\" test expression)", -1);  
         }  
         goto error;  
     }  
     maxDepth = envPtr->maxStackDepth;  
     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);  
       
     /*  
      * Compile the loop body.  
      */  
   
     bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);  
     envPtr->exceptArrayPtr[range].codeOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
     code = TclCompileCmdWord(interp, bodyTokenPtr+1,  
             bodyTokenPtr->numComponents, envPtr);  
     if (code != TCL_OK) {  
         if (code == TCL_ERROR) {  
             sprintf(buffer, "\n    (\"while\" body line %d)",  
                     interp->errorLine);  
             Tcl_AddObjErrorInfo(interp, buffer, -1);  
         }  
         goto error;  
     }  
     maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
     envPtr->exceptArrayPtr[range].numCodeBytes =  
             (envPtr->codeNext - envPtr->codeStart)  
             - envPtr->exceptArrayPtr[range].codeOffset;  
     TclEmitOpcode(INST_POP, envPtr);  
           
     /*  
      * Jump back to the test at the top of the loop. Generate a 4 byte jump  
      * if the distance to the test is > 120 bytes. This is conservative and  
      * ensures that we won't have to replace this jump if we later need to  
      * replace the ifFalse jump with a 4 byte jump.  
      */  
   
     jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);  
     jumpBackDist = (jumpBackOffset - testCodeOffset);  
     if (jumpBackDist > 120) {  
         TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);  
     } else {  
         TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);  
     }  
   
     /*  
      * Fix the target of the jumpFalse after the test.  
      */  
   
     jumpDist = (envPtr->codeNext - envPtr->codeStart)  
             - jumpFalseFixup.codeOffset;  
     if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {  
         /*  
          * Update the loop body's starting PC offset since it moved down.  
          */  
   
         envPtr->exceptArrayPtr[range].codeOffset += 3;  
   
         /*  
          * Update the jump back to the test at the top of the loop since it  
          * also moved down 3 bytes.  
          */  
   
         jumpBackOffset += 3;  
         jumpPc = (envPtr->codeStart + jumpBackOffset);  
         jumpBackDist += 3;  
         if (jumpBackDist > 120) {  
             TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);  
         } else {  
             TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);  
         }  
     }  
   
     /*  
      * Set the loop's break target.  
      */  
   
     envPtr->exceptArrayPtr[range].breakOffset =  
             (envPtr->codeNext - envPtr->codeStart);  
       
     /*  
      * The while command's result is an empty string.  
      */  
   
     TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);  
     if (maxDepth == 0) {  
         maxDepth = 1;  
     }  
     envPtr->maxStackDepth = maxDepth;  
     envPtr->exceptDepth--;  
     return TCL_OK;  
   
     error:  
     envPtr->maxStackDepth = maxDepth;  
     envPtr->exceptDepth--;  
     return code;  
 }  
   
   
 /* $History: tclcompcmds.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:28a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLCOMPCMDS.C */  
1    /* $Header$ */
2    /*
3     * tclCompCmds.c --
4     *
5     *      This file contains compilation procedures that compile various
6     *      Tcl commands into a sequence of instructions ("bytecodes").
7     *
8     * Copyright (c) 1997-1998 Sun Microsystems, Inc.
9     *
10     * See the file "license.terms" for information on usage and redistribution
11     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12     *
13     * RCS: @(#) $Id: tclcompcmds.c,v 1.1.1.1 2001/06/13 04:35:34 dtashley Exp $
14     */
15    
16    #include "tclInt.h"
17    #include "tclCompile.h"
18    
19    /*
20     * Prototypes for procedures defined later in this file:
21     */
22    
23    static ClientData       DupForeachInfo _ANSI_ARGS_((ClientData clientData));
24    static void             FreeForeachInfo _ANSI_ARGS_((
25                                ClientData clientData));
26    
27    /*
28     * The structures below define the AuxData types defined in this file.
29     */
30    
31    AuxDataType tclForeachInfoType = {
32        "ForeachInfo",                              /* name */
33        DupForeachInfo,                             /* dupProc */
34        FreeForeachInfo                             /* freeProc */
35    };
36    
37    /*
38     *----------------------------------------------------------------------
39     *
40     * TclCompileBreakCmd --
41     *
42     *      Procedure called to compile the "break" command.
43     *
44     * Results:
45     *      The return value is a standard Tcl result, which is TCL_OK unless
46     *      there was an error during compilation. If an error occurs then
47     *      the interpreter's result contains a standard error message.
48     *
49     *      envPtr->maxStackDepth is updated with the maximum number of stack
50     *      elements needed to execute the command.
51     *
52     * Side effects:
53     *      Instructions are added to envPtr to execute the "break" command
54     *      at runtime.
55     *
56     *----------------------------------------------------------------------
57     */
58    
59    int
60    TclCompileBreakCmd(interp, parsePtr, envPtr)
61        Tcl_Interp *interp;         /* Used for error reporting. */
62        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
63                                     * command created by Tcl_ParseCommand. */
64        CompileEnv *envPtr;         /* Holds resulting instructions. */
65    {
66        if (parsePtr->numWords != 1) {
67            Tcl_ResetResult(interp);
68            Tcl_AppendToObj(Tcl_GetObjResult(interp),
69                    "wrong # args: should be \"break\"", -1);
70            envPtr->maxStackDepth = 0;
71            return TCL_ERROR;
72        }
73    
74        /*
75         * Emit a break instruction.
76         */
77    
78        TclEmitOpcode(INST_BREAK, envPtr);
79        envPtr->maxStackDepth = 0;
80        return TCL_OK;
81    }
82    
83    /*
84     *----------------------------------------------------------------------
85     *
86     * TclCompileCatchCmd --
87     *
88     *      Procedure called to compile the "catch" command.
89     *
90     * Results:
91     *      The return value is a standard Tcl result, which is TCL_OK if
92     *      compilation was successful. If an error occurs then the
93     *      interpreter's result contains a standard error message and TCL_ERROR
94     *      is returned. If the command is too complex for TclCompileCatchCmd,
95     *      TCL_OUT_LINE_COMPILE is returned indicating that the catch command
96     *      should be compiled "out of line" by emitting code to invoke its
97     *      command procedure at runtime.
98     *
99     *      envPtr->maxStackDepth is updated with the maximum number of stack
100     *      elements needed to execute the command.
101     *
102     * Side effects:
103     *      Instructions are added to envPtr to execute the "catch" command
104     *      at runtime.
105     *
106     *----------------------------------------------------------------------
107     */
108    
109    int
110    TclCompileCatchCmd(interp, parsePtr, envPtr)
111        Tcl_Interp *interp;         /* Used for error reporting. */
112        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
113                                     * command created by Tcl_ParseCommand. */
114        CompileEnv *envPtr;         /* Holds resulting instructions. */
115    {
116        JumpFixup jumpFixup;
117        Tcl_Token *cmdTokenPtr, *nameTokenPtr;
118        char *name;
119        int localIndex, nameChars, range, maxDepth, startOffset, jumpDist;
120        int code;
121        char buffer[32 + TCL_INTEGER_SPACE];
122    
123        envPtr->maxStackDepth = 0;
124        if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
125            Tcl_ResetResult(interp);
126            Tcl_AppendToObj(Tcl_GetObjResult(interp),
127                    "wrong # args: should be \"catch command ?varName?\"", -1);
128            return TCL_ERROR;
129        }
130    
131        /*
132         * If a variable was specified and the catch command is at global level
133         * (not in a procedure), don't compile it inline: the payoff is
134         * too small.
135         */
136    
137        if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
138            return TCL_OUT_LINE_COMPILE;
139        }
140    
141        /*
142         * Make sure the variable name, if any, has no substitutions and just
143         * refers to a local scaler.
144         */
145    
146        localIndex = -1;
147        cmdTokenPtr = parsePtr->tokenPtr
148                + (parsePtr->tokenPtr->numComponents + 1);
149        if (parsePtr->numWords == 3) {
150            nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);
151            if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
152                name = nameTokenPtr[1].start;
153                nameChars = nameTokenPtr[1].size;
154                if (!TclIsLocalScalar(name, nameChars)) {
155                    return TCL_OUT_LINE_COMPILE;
156                }
157                localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
158                        nameTokenPtr[1].size, /*create*/ 1,
159                        /*flags*/ VAR_SCALAR, envPtr->procPtr);
160            } else {
161               return TCL_OUT_LINE_COMPILE;
162            }
163        }
164    
165        /*
166         * We will compile the catch command. Emit a beginCatch instruction at
167         * the start of the catch body: the subcommand it controls.
168         */
169    
170        maxDepth = 0;
171        
172        envPtr->exceptDepth++;
173        envPtr->maxExceptDepth =
174            TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
175        range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
176        TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
177    
178        startOffset = (envPtr->codeNext - envPtr->codeStart);
179        envPtr->exceptArrayPtr[range].codeOffset = startOffset;
180        code = TclCompileCmdWord(interp, cmdTokenPtr+1,
181                cmdTokenPtr->numComponents, envPtr);
182        if (code != TCL_OK) {
183            if (code == TCL_ERROR) {
184                sprintf(buffer, "\n    (\"catch\" body line %d)",
185                        interp->errorLine);
186                Tcl_AddObjErrorInfo(interp, buffer, -1);
187            }
188            goto done;
189        }
190        maxDepth = envPtr->maxStackDepth;
191        envPtr->exceptArrayPtr[range].numCodeBytes =
192                (envPtr->codeNext - envPtr->codeStart) - startOffset;
193                        
194        /*
195         * The "no errors" epilogue code: store the body's result into the
196         * variable (if any), push "0" (TCL_OK) as the catch's "no error"
197         * result, and jump around the "error case" code.
198         */
199    
200        if (localIndex != -1) {
201            if (localIndex <= 255) {
202                TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
203            } else {
204                TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
205            }
206        }
207        TclEmitOpcode(INST_POP, envPtr);
208        TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0),
209                envPtr);
210        if (maxDepth == 0) {
211            maxDepth = 1;
212        }
213        TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
214    
215        /*
216         * The "error case" code: store the body's result into the variable (if
217         * any), then push the error result code. The initial PC offset here is
218         * the catch's error target.
219         */
220    
221        envPtr->exceptArrayPtr[range].catchOffset =
222                (envPtr->codeNext - envPtr->codeStart);
223        if (localIndex != -1) {
224            TclEmitOpcode(INST_PUSH_RESULT, envPtr);
225            if (localIndex <= 255) {
226                TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
227            } else {
228                TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
229            }
230            TclEmitOpcode(INST_POP, envPtr);
231        }
232        TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
233    
234        /*
235         * Update the target of the jump after the "no errors" code, then emit
236         * an endCatch instruction at the end of the catch command.
237         */
238    
239        jumpDist = (envPtr->codeNext - envPtr->codeStart)
240                - jumpFixup.codeOffset;
241        if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
242            panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
243        }
244        TclEmitOpcode(INST_END_CATCH, envPtr);
245    
246        done:
247        envPtr->exceptDepth--;
248        envPtr->maxStackDepth = maxDepth;
249        return code;
250    }
251    
252    /*
253     *----------------------------------------------------------------------
254     *
255     * TclCompileContinueCmd --
256     *
257     *      Procedure called to compile the "continue" command.
258     *
259     * Results:
260     *      The return value is a standard Tcl result, which is TCL_OK unless
261     *      there was an error while parsing string. If an error occurs then
262     *      the interpreter's result contains a standard error message.
263     *
264     *      envPtr->maxStackDepth is updated with the maximum number of stack
265     *      elements needed to execute the command.
266     *
267     * Side effects:
268     *      Instructions are added to envPtr to execute the "continue" command
269     *      at runtime.
270     *
271     *----------------------------------------------------------------------
272     */
273    
274    int
275    TclCompileContinueCmd(interp, parsePtr, envPtr)
276        Tcl_Interp *interp;         /* Used for error reporting. */
277        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
278                                     * command created by Tcl_ParseCommand. */
279        CompileEnv *envPtr;         /* Holds resulting instructions. */
280    {
281        /*
282         * There should be no argument after the "continue".
283         */
284    
285        if (parsePtr->numWords != 1) {
286            Tcl_ResetResult(interp);
287            Tcl_AppendToObj(Tcl_GetObjResult(interp),
288                    "wrong # args: should be \"continue\"", -1);
289            envPtr->maxStackDepth = 0;
290            return TCL_ERROR;
291        }
292    
293        /*
294         * Emit a continue instruction.
295         */
296    
297        TclEmitOpcode(INST_CONTINUE, envPtr);
298        envPtr->maxStackDepth = 0;
299        return TCL_OK;
300    }
301    
302    /*
303     *----------------------------------------------------------------------
304     *
305     * TclCompileExprCmd --
306     *
307     *      Procedure called to compile the "expr" command.
308     *
309     * Results:
310     *      The return value is a standard Tcl result, which is TCL_OK
311     *      unless there was an error while parsing string. If an error occurs
312     *      then the interpreter's result contains a standard error message.
313     *
314     *      envPtr->maxStackDepth is updated with the maximum number of stack
315     *      elements needed to execute the "expr" command.
316     *
317     * Side effects:
318     *      Instructions are added to envPtr to execute the "expr" command
319     *      at runtime.
320     *
321     *----------------------------------------------------------------------
322     */
323    
324    int
325    TclCompileExprCmd(interp, parsePtr, envPtr)
326        Tcl_Interp *interp;         /* Used for error reporting. */
327        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
328                                     * command created by Tcl_ParseCommand. */
329        CompileEnv *envPtr;         /* Holds resulting instructions. */
330    {
331        Tcl_Token *firstWordPtr;
332    
333        envPtr->maxStackDepth = 0;
334        if (parsePtr->numWords == 1) {
335            Tcl_ResetResult(interp);
336            Tcl_AppendToObj(Tcl_GetObjResult(interp),
337                    "wrong # args: should be \"expr arg ?arg ...?\"", -1);
338            return TCL_ERROR;
339        }
340    
341        firstWordPtr = parsePtr->tokenPtr
342                + (parsePtr->tokenPtr->numComponents + 1);
343        return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
344                envPtr);
345    }
346    
347    /*
348     *----------------------------------------------------------------------
349     *
350     * TclCompileForCmd --
351     *
352     *      Procedure called to compile the "for" command.
353     *
354     * Results:
355     *      The return value is a standard Tcl result, which is TCL_OK unless
356     *      there was an error while parsing string. If an error occurs then
357     *      the interpreter's result contains a standard error message.
358     *
359     *      envPtr->maxStackDepth is updated with the maximum number of stack
360     *      elements needed to execute the command.
361     *
362     * Side effects:
363     *      Instructions are added to envPtr to execute the "for" command
364     *      at runtime.
365     *
366     *----------------------------------------------------------------------
367     */
368    
369    int
370    TclCompileForCmd(interp, parsePtr, envPtr)
371        Tcl_Interp *interp;         /* Used for error reporting. */
372        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
373                                     * command created by Tcl_ParseCommand. */
374        CompileEnv *envPtr;         /* Holds resulting instructions. */
375    {
376        Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
377        JumpFixup jumpFalseFixup;
378        int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist;
379        int bodyRange, nextRange, code;
380        unsigned char *jumpPc;
381        char buffer[32 + TCL_INTEGER_SPACE];
382    
383        envPtr->maxStackDepth = 0;
384        if (parsePtr->numWords != 5) {
385            Tcl_ResetResult(interp);
386            Tcl_AppendToObj(Tcl_GetObjResult(interp),
387                    "wrong # args: should be \"for start test next command\"", -1);
388            return TCL_ERROR;
389        }
390    
391        /*
392         * If the test expression requires substitutions, don't compile the for
393         * command inline. E.g., the expression might cause the loop to never
394         * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
395         */
396    
397        startTokenPtr = parsePtr->tokenPtr
398                + (parsePtr->tokenPtr->numComponents + 1);
399        testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
400        if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
401            return TCL_OUT_LINE_COMPILE;
402        }
403    
404        /*
405         * Create ExceptionRange records for the body and the "next" command.
406         * The "next" command's ExceptionRange supports break but not continue
407         * (and has a -1 continueOffset).
408         */
409    
410        envPtr->exceptDepth++;
411        envPtr->maxExceptDepth =
412                TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
413        bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
414        nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
415    
416        /*
417         * Inline compile the initial command.
418         */
419    
420        maxDepth = 0;
421        code = TclCompileCmdWord(interp, startTokenPtr+1,
422                startTokenPtr->numComponents, envPtr);
423        if (code != TCL_OK) {
424            if (code == TCL_ERROR) {
425                Tcl_AddObjErrorInfo(interp,
426                        "\n    (\"for\" initial command)", -1);
427            }
428            goto done;
429        }
430        maxDepth = envPtr->maxStackDepth;
431        TclEmitOpcode(INST_POP, envPtr);
432        
433        /*
434         * Compile the test then emit the conditional jump that exits the for.
435         */
436    
437        testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
438        code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
439        if (code != TCL_OK) {
440            if (code == TCL_ERROR) {
441                Tcl_AddObjErrorInfo(interp,
442                        "\n    (\"for\" test expression)", -1);
443            }
444            goto done;
445        }
446        maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
447        TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
448    
449        /*
450         * Compile the loop body.
451         */
452    
453        nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
454        bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
455        envPtr->exceptArrayPtr[bodyRange].codeOffset =
456                (envPtr->codeNext - envPtr->codeStart);
457        code = TclCompileCmdWord(interp, bodyTokenPtr+1,
458                bodyTokenPtr->numComponents, envPtr);
459        if (code != TCL_OK) {
460            if (code == TCL_ERROR) {
461                sprintf(buffer, "\n    (\"for\" body line %d)",
462                        interp->errorLine);
463                Tcl_AddObjErrorInfo(interp, buffer, -1);
464            }
465            goto done;
466        }
467        maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
468        envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
469                (envPtr->codeNext - envPtr->codeStart)
470                - envPtr->exceptArrayPtr[bodyRange].codeOffset;
471        TclEmitOpcode(INST_POP, envPtr);
472    
473        /*
474         * Compile the "next" subcommand.
475         */
476    
477        envPtr->exceptArrayPtr[bodyRange].continueOffset =
478                (envPtr->codeNext - envPtr->codeStart);
479        envPtr->exceptArrayPtr[nextRange].codeOffset =
480                (envPtr->codeNext - envPtr->codeStart);
481        code = TclCompileCmdWord(interp, nextTokenPtr+1,
482                nextTokenPtr->numComponents, envPtr);
483        if (code != TCL_OK) {
484            if (code == TCL_ERROR) {
485                Tcl_AddObjErrorInfo(interp,
486                        "\n    (\"for\" loop-end command)", -1);
487            }
488            goto done;
489        }
490        maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
491        envPtr->exceptArrayPtr[nextRange].numCodeBytes =
492                (envPtr->codeNext - envPtr->codeStart)
493                - envPtr->exceptArrayPtr[nextRange].codeOffset;
494        TclEmitOpcode(INST_POP, envPtr);
495            
496        /*
497         * Jump back to the test at the top of the loop. Generate a 4 byte jump
498         * if the distance to the test is > 120 bytes. This is conservative and
499         * ensures that we won't have to replace this jump if we later need to
500         * replace the ifFalse jump with a 4 byte jump.
501         */
502    
503        jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
504        jumpBackDist = (jumpBackOffset - testCodeOffset);
505        if (jumpBackDist > 120) {
506            TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
507        } else {
508            TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
509        }
510    
511        /*
512         * Fix the target of the jumpFalse after the test.
513         */
514    
515        jumpDist = (envPtr->codeNext - envPtr->codeStart)
516                - jumpFalseFixup.codeOffset;
517        if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
518            /*
519             * Update the loop body and "next" command ExceptionRanges since
520             * they moved down.
521             */
522    
523            envPtr->exceptArrayPtr[bodyRange].codeOffset += 3;
524            envPtr->exceptArrayPtr[bodyRange].continueOffset += 3;
525            envPtr->exceptArrayPtr[nextRange].codeOffset += 3;
526    
527            /*
528             * Update the jump back to the test at the top of the loop since it
529             * also moved down 3 bytes.
530             */
531    
532            jumpBackOffset += 3;
533            jumpPc = (envPtr->codeStart + jumpBackOffset);
534            jumpBackDist += 3;
535            if (jumpBackDist > 120) {
536                TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
537            } else {
538                TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
539            }
540        }
541        
542        /*
543         * Set the loop's break target.
544         */
545    
546        envPtr->exceptArrayPtr[bodyRange].breakOffset =
547                envPtr->exceptArrayPtr[nextRange].breakOffset =
548                (envPtr->codeNext - envPtr->codeStart);
549        
550        /*
551         * The for command's result is an empty string.
552         */
553    
554        TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
555        if (maxDepth == 0) {
556            maxDepth = 1;
557        }
558        code = TCL_OK;
559    
560        done:
561        envPtr->maxStackDepth = maxDepth;
562        envPtr->exceptDepth--;
563        return code;
564    }
565    
566    /*
567     *----------------------------------------------------------------------
568     *
569     * TclCompileForeachCmd --
570     *
571     *      Procedure called to compile the "foreach" command.
572     *
573     * Results:
574     *      The return value is a standard Tcl result, which is TCL_OK if
575     *      compilation was successful. If an error occurs then the
576     *      interpreter's result contains a standard error message and TCL_ERROR
577     *      is returned. If the command is too complex for TclCompileForeachCmd,
578     *      TCL_OUT_LINE_COMPILE is returned indicating that the foreach command
579     *      should be compiled "out of line" by emitting code to invoke its
580     *      command procedure at runtime.
581     *
582     *      envPtr->maxStackDepth is updated with the maximum number of stack
583     *      elements needed to execute the "while" command.
584     *
585     * Side effects:
586     *      Instructions are added to envPtr to execute the "foreach" command
587     *      at runtime.
588     *
589     *----------------------------------------------------------------------
590     */
591    
592    int
593    TclCompileForeachCmd(interp, parsePtr, envPtr)
594        Tcl_Interp *interp;         /* Used for error reporting. */
595        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
596                                     * command created by Tcl_ParseCommand. */
597        CompileEnv *envPtr;         /* Holds resulting instructions. */
598    {
599        Proc *procPtr = envPtr->procPtr;
600        ForeachInfo *infoPtr;       /* Points to the structure describing this
601                                     * foreach command. Stored in a AuxData
602                                     * record in the ByteCode. */
603        int firstValueTemp;         /* Index of the first temp var in the frame
604                                     * used to point to a value list. */
605        int loopCtTemp;             /* Index of temp var holding the loop's
606                                     * iteration count. */
607        Tcl_Token *tokenPtr, *bodyTokenPtr;
608        char *varList;
609        unsigned char *jumpPc;
610        JumpFixup jumpFalseFixup;
611        int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range;
612        int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
613        char savedChar;
614        char buffer[32 + TCL_INTEGER_SPACE];
615    
616        /*
617         * We parse the variable list argument words and create two arrays:
618         *    varcList[i] is number of variables in i-th var list
619         *    varvList[i] points to array of var names in i-th var list
620         */
621    
622    #define STATIC_VAR_LIST_SIZE 5
623        int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
624        char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
625        int *varcList = varcListStaticSpace;
626        char ***varvList = varvListStaticSpace;
627    
628        /*
629         * If the foreach command isn't in a procedure, don't compile it inline:
630         * the payoff is too small.
631         */
632    
633        envPtr->maxStackDepth = 0;
634        if (procPtr == NULL) {
635            return TCL_OUT_LINE_COMPILE;
636        }
637    
638        maxDepth = 0;
639        
640        numWords = parsePtr->numWords;
641        if ((numWords < 4) || (numWords%2 != 0)) {
642            Tcl_ResetResult(interp);
643            Tcl_AppendToObj(Tcl_GetObjResult(interp),
644                    "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
645            return TCL_ERROR;
646        }
647    
648        /*
649         * Allocate storage for the varcList and varvList arrays if necessary.
650         */
651    
652        numLists = (numWords - 2)/2;
653        if (numLists > STATIC_VAR_LIST_SIZE) {
654            varcList = (int *) ckalloc(numLists * sizeof(int));
655            varvList = (char ***) ckalloc(numLists * sizeof(char **));
656        }
657        for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
658            varcList[loopIndex] = 0;
659            varvList[loopIndex] = (char **) NULL;
660        }
661        
662        /*
663         * Set the exception stack depth.
664         */
665    
666        envPtr->exceptDepth++;
667        envPtr->maxExceptDepth =
668            TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
669    
670        /*
671         * Break up each var list and set the varcList and varvList arrays.
672         * Don't compile the foreach inline if any var name needs substitutions
673         * or isn't a scalar, or if any var list needs substitutions.
674         */
675    
676        loopIndex = 0;
677        for (i = 0, tokenPtr = parsePtr->tokenPtr;
678                i < numWords-1;
679                i++, tokenPtr += (tokenPtr->numComponents + 1)) {
680            if (i%2 == 1) {
681                if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
682                    code = TCL_OUT_LINE_COMPILE;
683                    goto done;
684                }
685                varList = tokenPtr[1].start;
686                savedChar = varList[tokenPtr[1].size];
687    
688                /*
689                 * Note there is a danger that modifying the string could have
690                 * undesirable side effects.  In this case, Tcl_SplitList does
691                 * not have any dependencies on shared strings so we should be
692                 * safe.
693                 */
694    
695                varList[tokenPtr[1].size] = '\0';
696                code = Tcl_SplitList(interp, varList,
697                        &varcList[loopIndex], &varvList[loopIndex]);
698                varList[tokenPtr[1].size] = savedChar;
699                if (code != TCL_OK) {
700                    goto done;
701                }
702    
703                numVars = varcList[loopIndex];
704                for (j = 0;  j < numVars;  j++) {
705                    char *varName = varvList[loopIndex][j];
706                    if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
707                        code = TCL_OUT_LINE_COMPILE;
708                        goto done;
709                    }
710                }
711                loopIndex++;
712            }
713        }
714    
715        /*
716         * We will compile the foreach command.
717         * Reserve (numLists + 1) temporary variables:
718         *    - numLists temps to hold each value list
719         *    - 1 temp for the loop counter (index of next element in each list)
720         * At this time we don't try to reuse temporaries; if there are two
721         * nonoverlapping foreach loops, they don't share any temps.
722         */
723    
724        firstValueTemp = -1;
725        for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
726            tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
727                    /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
728            if (loopIndex == 0) {
729                firstValueTemp = tempVar;
730            }
731        }
732        loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
733                /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
734        
735        /*
736         * Create and initialize the ForeachInfo and ForeachVarList data
737         * structures describing this command. Then create a AuxData record
738         * pointing to the ForeachInfo structure.
739         */
740    
741        infoPtr = (ForeachInfo *) ckalloc((unsigned)
742                (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
743        infoPtr->numLists = numLists;
744        infoPtr->firstValueTemp = firstValueTemp;
745        infoPtr->loopCtTemp = loopCtTemp;
746        for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
747            ForeachVarList *varListPtr;
748            numVars = varcList[loopIndex];
749            varListPtr = (ForeachVarList *) ckalloc((unsigned)
750                    sizeof(ForeachVarList) + (numVars * sizeof(int)));
751            varListPtr->numVars = numVars;
752            for (j = 0;  j < numVars;  j++) {
753                char *varName = varvList[loopIndex][j];
754                int nameChars = strlen(varName);
755                varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
756                        nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
757            }
758            infoPtr->varLists[loopIndex] = varListPtr;
759        }
760        infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
761    
762        /*
763         * Evaluate then store each value list in the associated temporary.
764         */
765    
766        range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
767        
768        loopIndex = 0;
769        for (i = 0, tokenPtr = parsePtr->tokenPtr;
770                i < numWords-1;
771                i++, tokenPtr += (tokenPtr->numComponents + 1)) {
772            if ((i%2 == 0) && (i > 0)) {
773                code = TclCompileTokens(interp, tokenPtr+1,
774                        tokenPtr->numComponents, envPtr);
775                if (code != TCL_OK) {
776                    goto done;
777                }
778                maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
779    
780                tempVar = (firstValueTemp + loopIndex);
781                if (tempVar <= 255) {
782                    TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
783                } else {
784                    TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
785                }
786                TclEmitOpcode(INST_POP, envPtr);
787                loopIndex++;
788            }
789        }
790        bodyTokenPtr = tokenPtr;
791    
792        /*
793         * Initialize the temporary var that holds the count of loop iterations.
794         */
795    
796        TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
797        
798        /*
799         * Top of loop code: assign each loop variable and check whether
800         * to terminate the loop.
801         */
802    
803        envPtr->exceptArrayPtr[range].continueOffset =
804                (envPtr->codeNext - envPtr->codeStart);
805        TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
806        TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
807        
808        /*
809         * Inline compile the loop body.
810         */
811    
812        envPtr->exceptArrayPtr[range].codeOffset =
813                (envPtr->codeNext - envPtr->codeStart);
814        code = TclCompileCmdWord(interp, bodyTokenPtr+1,
815                bodyTokenPtr->numComponents, envPtr);
816        if (code != TCL_OK) {
817            if (code == TCL_ERROR) {
818                sprintf(buffer, "\n    (\"foreach\" body line %d)",
819                        interp->errorLine);
820                Tcl_AddObjErrorInfo(interp, buffer, -1);
821            }
822            goto done;
823        }
824        maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
825        envPtr->exceptArrayPtr[range].numCodeBytes =
826                (envPtr->codeNext - envPtr->codeStart)
827                - envPtr->exceptArrayPtr[range].codeOffset;
828        TclEmitOpcode(INST_POP, envPtr);
829            
830        /*
831         * Jump back to the test at the top of the loop. Generate a 4 byte jump
832         * if the distance to the test is > 120 bytes. This is conservative and
833         * ensures that we won't have to replace this jump if we later need to
834         * replace the ifFalse jump with a 4 byte jump.
835         */
836    
837        jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
838        jumpBackDist =
839            (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
840        if (jumpBackDist > 120) {
841            TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
842        } else {
843            TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
844        }
845    
846        /*
847         * Fix the target of the jump after the foreach_step test.
848         */
849    
850        jumpDist = (envPtr->codeNext - envPtr->codeStart)
851                - jumpFalseFixup.codeOffset;
852        if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
853            /*
854             * Update the loop body's starting PC offset since it moved down.
855             */
856    
857            envPtr->exceptArrayPtr[range].codeOffset += 3;
858    
859            /*
860             * Update the jump back to the test at the top of the loop since it
861             * also moved down 3 bytes.
862             */
863    
864            jumpBackOffset += 3;
865            jumpPc = (envPtr->codeStart + jumpBackOffset);
866            jumpBackDist += 3;
867            if (jumpBackDist > 120) {
868                TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
869            } else {
870                TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
871            }
872        }
873    
874        /*
875         * Set the loop's break target.
876         */
877    
878        envPtr->exceptArrayPtr[range].breakOffset =
879                (envPtr->codeNext - envPtr->codeStart);
880        
881        /*
882         * The foreach command's result is an empty string.
883         */
884    
885        TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
886        if (maxDepth == 0) {
887            maxDepth = 1;
888        }
889    
890        done:
891        for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
892            if (varvList[loopIndex] != (char **) NULL) {
893                ckfree((char *) varvList[loopIndex]);
894            }
895        }
896        if (varcList != varcListStaticSpace) {
897            ckfree((char *) varcList);
898            ckfree((char *) varvList);
899        }
900        envPtr->maxStackDepth = maxDepth;
901        envPtr->exceptDepth--;
902        return code;
903    }
904    
905    /*
906     *----------------------------------------------------------------------
907     *
908     * DupForeachInfo --
909     *
910     *      This procedure duplicates a ForeachInfo structure created as
911     *      auxiliary data during the compilation of a foreach command.
912     *
913     * Results:
914     *      A pointer to a newly allocated copy of the existing ForeachInfo
915     *      structure is returned.
916     *
917     * Side effects:
918     *      Storage for the copied ForeachInfo record is allocated. If the
919     *      original ForeachInfo structure pointed to any ForeachVarList
920     *      records, these structures are also copied and pointers to them
921     *      are stored in the new ForeachInfo record.
922     *
923     *----------------------------------------------------------------------
924     */
925    
926    static ClientData
927    DupForeachInfo(clientData)
928        ClientData clientData;      /* The foreach command's compilation
929                                     * auxiliary data to duplicate. */
930    {
931        register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
932        ForeachInfo *dupPtr;
933        register ForeachVarList *srcListPtr, *dupListPtr;
934        int numLists = srcPtr->numLists;
935        int numVars, i, j;
936        
937        dupPtr = (ForeachInfo *) ckalloc((unsigned)
938                (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
939        dupPtr->numLists = numLists;
940        dupPtr->firstValueTemp = srcPtr->firstValueTemp;
941        dupPtr->loopCtTemp = srcPtr->loopCtTemp;
942        
943        for (i = 0;  i < numLists;  i++) {
944            srcListPtr = srcPtr->varLists[i];
945            numVars = srcListPtr->numVars;
946            dupListPtr = (ForeachVarList *) ckalloc((unsigned)
947                    sizeof(ForeachVarList) + numVars*sizeof(int));
948            dupListPtr->numVars = numVars;
949            for (j = 0;  j < numVars;  j++) {
950                dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
951            }
952            dupPtr->varLists[i] = dupListPtr;
953        }
954        return (ClientData) dupPtr;
955    }
956    
957    /*
958     *----------------------------------------------------------------------
959     *
960     * FreeForeachInfo --
961     *
962     *      Procedure to free a ForeachInfo structure created as auxiliary data
963     *      during the compilation of a foreach command.
964     *
965     * Results:
966     *      None.
967     *
968     * Side effects:
969     *      Storage for the ForeachInfo structure pointed to by the ClientData
970     *      argument is freed as is any ForeachVarList record pointed to by the
971     *      ForeachInfo structure.
972     *
973     *----------------------------------------------------------------------
974     */
975    
976    static void
977    FreeForeachInfo(clientData)
978        ClientData clientData;      /* The foreach command's compilation
979                                     * auxiliary data to free. */
980    {
981        register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
982        register ForeachVarList *listPtr;
983        int numLists = infoPtr->numLists;
984        register int i;
985    
986        for (i = 0;  i < numLists;  i++) {
987            listPtr = infoPtr->varLists[i];
988            ckfree((char *) listPtr);
989        }
990        ckfree((char *) infoPtr);
991    }
992    
993    /*
994     *----------------------------------------------------------------------
995     *
996     * TclCompileIfCmd --
997     *
998     *      Procedure called to compile the "if" command.
999     *
1000     * Results:
1001     *      The return value is a standard Tcl result, which is TCL_OK if
1002     *      compilation was successful. If an error occurs then the
1003     *      interpreter's result contains a standard error message and TCL_ERROR
1004     *      is returned. If the command is too complex for TclCompileIfCmd,
1005     *      TCL_OUT_LINE_COMPILE is returned indicating that the if command
1006     *      should be compiled "out of line" by emitting code to invoke its
1007     *      command procedure at runtime.
1008     *
1009     *      envPtr->maxStackDepth is updated with the maximum number of stack
1010     *      elements needed to execute the command.
1011     *
1012     * Side effects:
1013     *      Instructions are added to envPtr to execute the "if" command
1014     *      at runtime.
1015     *
1016     *----------------------------------------------------------------------
1017     */
1018    
1019    int
1020    TclCompileIfCmd(interp, parsePtr, envPtr)
1021        Tcl_Interp *interp;         /* Used for error reporting. */
1022        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
1023                                     * command created by Tcl_ParseCommand. */
1024        CompileEnv *envPtr;         /* Holds resulting instructions. */
1025    {
1026        JumpFixupArray jumpFalseFixupArray;
1027                                    /* Used to fix the ifFalse jump after each
1028                                     * test when its target PC is determined. */
1029        JumpFixupArray jumpEndFixupArray;
1030                                    /* Used to fix the jump after each "then"
1031                                     * body to the end of the "if" when that PC
1032                                     * is determined. */
1033        Tcl_Token *tokenPtr, *testTokenPtr;
1034        int jumpDist, jumpFalseDist, jumpIndex;
1035        int numWords, wordIdx, numBytes, maxDepth, j, code;
1036        char *word;
1037        char buffer[100];
1038    
1039        TclInitJumpFixupArray(&jumpFalseFixupArray);
1040        TclInitJumpFixupArray(&jumpEndFixupArray);
1041        maxDepth = 0;
1042        code = TCL_OK;
1043    
1044        /*
1045         * Each iteration of this loop compiles one "if expr ?then? body"
1046         * or "elseif expr ?then? body" clause.
1047         */
1048    
1049        tokenPtr = parsePtr->tokenPtr;
1050        wordIdx = 0;
1051        numWords = parsePtr->numWords;
1052        while (wordIdx < numWords) {
1053            /*
1054             * Stop looping if the token isn't "if" or "elseif".
1055             */
1056    
1057            if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1058                break;
1059            }
1060            word = tokenPtr[1].start;
1061            numBytes = tokenPtr[1].size;
1062            if ((tokenPtr == parsePtr->tokenPtr)
1063                    || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
1064                tokenPtr += (tokenPtr->numComponents + 1);
1065                wordIdx++;
1066            } else {
1067                break;
1068            }
1069            if (wordIdx >= numWords) {
1070                sprintf(buffer,
1071                        "wrong # args: no expression after \"%.30s\" argument",
1072                        word);
1073                Tcl_ResetResult(interp);
1074                Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
1075                code = TCL_ERROR;
1076                goto done;
1077            }
1078    
1079            /*
1080             * Compile the test expression then emit the conditional jump
1081             * around the "then" part. If the expression word isn't simple,
1082             * we back off and compile the if command out-of-line.
1083             */
1084            
1085            testTokenPtr = tokenPtr;
1086            code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
1087            if (code != TCL_OK) {
1088                if (code == TCL_ERROR) {
1089                    Tcl_AddObjErrorInfo(interp,
1090                            "\n    (\"if\" test expression)", -1);
1091                }
1092                goto done;
1093            }
1094            maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
1095            if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
1096                TclExpandJumpFixupArray(&jumpFalseFixupArray);
1097            }
1098            jumpIndex = jumpFalseFixupArray.next;
1099            jumpFalseFixupArray.next++;
1100            TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
1101                    &(jumpFalseFixupArray.fixup[jumpIndex]));
1102            
1103            /*
1104             * Skip over the optional "then" before the then clause.
1105             */
1106    
1107            tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
1108            wordIdx++;
1109            if (wordIdx >= numWords) {
1110                sprintf(buffer, "wrong # args: no script following \"%.20s\" argument", testTokenPtr->start);
1111                Tcl_ResetResult(interp);
1112                Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
1113                code = TCL_ERROR;
1114                goto done;
1115            }
1116            if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1117                word = tokenPtr[1].start;
1118                numBytes = tokenPtr[1].size;
1119                if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
1120                    tokenPtr += (tokenPtr->numComponents + 1);
1121                    wordIdx++;
1122                    if (wordIdx >= numWords) {
1123                        Tcl_ResetResult(interp);
1124                        Tcl_AppendToObj(Tcl_GetObjResult(interp),
1125                                "wrong # args: no script following \"then\" argument", -1);
1126                        code = TCL_ERROR;
1127                        goto done;
1128                    }
1129                }
1130            }
1131    
1132            /*
1133             * Compile the "then" command body.
1134             */
1135    
1136            code = TclCompileCmdWord(interp, tokenPtr+1,
1137                    tokenPtr->numComponents, envPtr);
1138            if (code != TCL_OK) {
1139                if (code == TCL_ERROR) {
1140                    sprintf(buffer, "\n    (\"if\" then script line %d)",
1141                            interp->errorLine);
1142                    Tcl_AddObjErrorInfo(interp, buffer, -1);
1143                }
1144                goto done;
1145            }
1146            maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
1147    
1148            /*
1149             * Jump to the end of the "if" command. Both jumpFalseFixupArray and
1150             * jumpEndFixupArray are indexed by "jumpIndex".
1151             */
1152    
1153            if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
1154                TclExpandJumpFixupArray(&jumpEndFixupArray);
1155            }
1156            jumpEndFixupArray.next++;
1157            TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
1158                    &(jumpEndFixupArray.fixup[jumpIndex]));
1159    
1160            /*
1161             * Fix the target of the jumpFalse after the test. Generate a 4 byte
1162             * jump if the distance is > 120 bytes. This is conservative, and
1163             * ensures that we won't have to replace this jump if we later also
1164             * need to replace the proceeding jump to the end of the "if" with a
1165             * 4 byte jump.
1166             */
1167    
1168            jumpDist = (envPtr->codeNext - envPtr->codeStart)
1169                    - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
1170            if (TclFixupForwardJump(envPtr,
1171                    &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
1172                /*
1173                 * Adjust the code offset for the proceeding jump to the end
1174                 * of the "if" command.
1175                 */
1176    
1177                jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
1178            }
1179    
1180            tokenPtr += (tokenPtr->numComponents + 1);
1181            wordIdx++;
1182        }
1183    
1184        /*
1185         * Check for the optional else clause.
1186         */
1187    
1188        if ((wordIdx < numWords)
1189                && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
1190            /*
1191             * There is an else clause. Skip over the optional "else" word.
1192             */
1193            
1194            word = tokenPtr[1].start;
1195            numBytes = tokenPtr[1].size;
1196            if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
1197                tokenPtr += (tokenPtr->numComponents + 1);
1198                wordIdx++;
1199                if (wordIdx >= numWords) {
1200                    Tcl_ResetResult(interp);
1201                    Tcl_AppendToObj(Tcl_GetObjResult(interp),
1202                            "wrong # args: no script following \"else\" argument", -1);
1203                    code = TCL_ERROR;
1204                    goto done;
1205                }
1206            }
1207    
1208            /*
1209             * Compile the else command body.
1210             */
1211            
1212            code = TclCompileCmdWord(interp, tokenPtr+1,
1213                    tokenPtr->numComponents, envPtr);
1214            if (code != TCL_OK) {
1215                if (code == TCL_ERROR) {
1216                    sprintf(buffer, "\n    (\"if\" else script line %d)",
1217                            interp->errorLine);
1218                    Tcl_AddObjErrorInfo(interp, buffer, -1);
1219                }
1220                goto done;
1221            }
1222            maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
1223    
1224            /*
1225             * Make sure there are no words after the else clause.
1226             */
1227            
1228            wordIdx++;
1229            if (wordIdx < numWords) {
1230                Tcl_ResetResult(interp);
1231                Tcl_AppendToObj(Tcl_GetObjResult(interp),
1232                        "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
1233                code = TCL_ERROR;
1234                goto done;
1235            }
1236        } else {
1237            /*
1238             * No else clause: the "if" command's result is an empty string.
1239             */
1240    
1241            TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr);
1242            maxDepth = TclMax(1, maxDepth);
1243        }
1244    
1245        /*
1246         * Fix the unconditional jumps to the end of the "if" command.
1247         */
1248        
1249        for (j = jumpEndFixupArray.next;  j > 0;  j--) {
1250            jumpIndex = (j - 1);    /* i.e. process the closest jump first */
1251            jumpDist = (envPtr->codeNext - envPtr->codeStart)
1252                    - jumpEndFixupArray.fixup[jumpIndex].codeOffset;
1253            if (TclFixupForwardJump(envPtr,
1254                    &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
1255                /*
1256                 * Adjust the immediately preceeding "ifFalse" jump. We moved
1257                 * it's target (just after this jump) down three bytes.
1258                 */
1259    
1260                unsigned char *ifFalsePc = envPtr->codeStart
1261                        + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
1262                unsigned char opCode = *ifFalsePc;
1263                if (opCode == INST_JUMP_FALSE1) {
1264                    jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
1265                    jumpFalseDist += 3;
1266                    TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
1267                } else if (opCode == INST_JUMP_FALSE4) {
1268                    jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
1269                    jumpFalseDist += 3;
1270                    TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
1271                } else {
1272                    panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
1273                }
1274            }
1275        }
1276            
1277        /*
1278         * Free the jumpFixupArray array if malloc'ed storage was used.
1279         */
1280    
1281        done:
1282        TclFreeJumpFixupArray(&jumpFalseFixupArray);
1283        TclFreeJumpFixupArray(&jumpEndFixupArray);
1284        envPtr->maxStackDepth = maxDepth;
1285        return code;
1286    }
1287    
1288    /*
1289     *----------------------------------------------------------------------
1290     *
1291     * TclCompileIncrCmd --
1292     *
1293     *      Procedure called to compile the "incr" command.
1294     *
1295     * Results:
1296     *      The return value is a standard Tcl result, which is TCL_OK if
1297     *      compilation was successful. If an error occurs then the
1298     *      interpreter's result contains a standard error message and TCL_ERROR
1299     *      is returned. If the command is too complex for TclCompileIncrCmd,
1300     *      TCL_OUT_LINE_COMPILE is returned indicating that the incr command
1301     *      should be compiled "out of line" by emitting code to invoke its
1302     *      command procedure at runtime.
1303     *
1304     *      envPtr->maxStackDepth is updated with the maximum number of stack
1305     *      elements needed to execute the "incr" command.
1306     *
1307     * Side effects:
1308     *      Instructions are added to envPtr to execute the "incr" command
1309     *      at runtime.
1310     *
1311     *----------------------------------------------------------------------
1312     */
1313    
1314    int
1315    TclCompileIncrCmd(interp, parsePtr, envPtr)
1316        Tcl_Interp *interp;         /* Used for error reporting. */
1317        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
1318                                     * command created by Tcl_ParseCommand. */
1319        CompileEnv *envPtr;         /* Holds resulting instructions. */
1320    {
1321        Tcl_Token *varTokenPtr, *incrTokenPtr;
1322        Tcl_Parse elemParse;
1323        int gotElemParse = 0;
1324        char *name, *elName, *p;
1325        int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code;
1326        int maxDepth = 0;
1327        char buffer[160];
1328    
1329        envPtr->maxStackDepth = 0;
1330        if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
1331            Tcl_ResetResult(interp);
1332            Tcl_AppendToObj(Tcl_GetObjResult(interp),
1333                    "wrong # args: should be \"incr varName ?increment?\"", -1);
1334            return TCL_ERROR;
1335        }
1336        
1337        name = NULL;
1338        elName = NULL;
1339        elNameChars = 0;
1340        localIndex = -1;
1341        code = TCL_OK;
1342    
1343        varTokenPtr = parsePtr->tokenPtr
1344                + (parsePtr->tokenPtr->numComponents + 1);
1345        /*
1346         * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
1347         * curly braces surround the variable name.
1348         * This really matters for array elements to handle things like
1349         *    set {x($foo)} 5
1350         * which raises an undefined var error if we are not careful here.
1351         * This goes with the hack in TclCompileSetCmd.
1352         */
1353        if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
1354                (varTokenPtr->start[0] != '{')) {
1355            /*
1356             * A simple variable name. Divide it up into "name" and "elName"
1357             * strings. If it is not a local variable, look it up at runtime.
1358             */
1359            
1360            name = varTokenPtr[1].start;
1361            nameChars = varTokenPtr[1].size;
1362            for (i = 0, p = name;  i < nameChars;  i++, p++) {
1363                if (*p == '(') {
1364                    char *openParen = p;
1365                    p = (name + nameChars-1);      
1366                    if (*p == ')') { /* last char is ')' => array reference */
1367                        nameChars = (openParen - name);
1368                        elName = openParen+1;
1369                        elNameChars = (p - elName);
1370                    }
1371                    break;
1372                }
1373            }
1374            if (envPtr->procPtr != NULL) {
1375                localIndex = TclFindCompiledLocal(name, nameChars,
1376                        /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
1377                if (localIndex > 255) {           /* we'll push the name */
1378                    localIndex = -1;
1379                }
1380            }
1381            if (localIndex < 0) {
1382                TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,
1383                            /*onHeap*/ 0), envPtr);
1384                maxDepth = 1;
1385            }
1386    
1387            /*
1388             * Compile the element script, if any.
1389             */
1390            
1391            if (elName != NULL) {
1392                /*
1393                 * Temporarily replace the '(' and ')' by '"'s.
1394                 */
1395                
1396                *(elName-1) = '"';
1397                *(elName+elNameChars) = '"';
1398                code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,
1399                        /*nested*/ 0, &elemParse);
1400                *(elName-1) = '(';
1401                *(elName+elNameChars) = ')';
1402                gotElemParse = 1;
1403                if ((code != TCL_OK) || (elemParse.numWords > 1)) {
1404                    sprintf(buffer, "\n    (parsing index for array \"%.*s\")",
1405                            TclMin(nameChars, 100), name);
1406                    Tcl_AddObjErrorInfo(interp, buffer, -1);
1407                    code = TCL_ERROR;
1408                    goto done;
1409                } else if (elemParse.numWords == 1) {
1410                    code = TclCompileTokens(interp, elemParse.tokenPtr+1,
1411                            elemParse.tokenPtr->numComponents, envPtr);
1412                    if (code != TCL_OK) {
1413                        goto done;
1414                    }
1415                    maxDepth += envPtr->maxStackDepth;
1416                } else {
1417                    TclEmitPush(TclRegisterLiteral(envPtr, "", 0,
1418                            /*alreadyAlloced*/ 0), envPtr);
1419                    maxDepth += 1;
1420                }
1421            }
1422        } else {
1423            /*
1424             * Not a simple variable name. Look it up at runtime.
1425             */
1426            
1427            code = TclCompileTokens(interp, varTokenPtr+1,
1428                    varTokenPtr->numComponents, envPtr);
1429            if (code != TCL_OK) {
1430                goto done;
1431            }
1432            maxDepth = envPtr->maxStackDepth;
1433        }
1434        
1435        /*
1436         * If an increment is given, push it, but see first if it's a small
1437         * integer.
1438         */
1439    
1440        haveImmValue = 0;
1441        immValue = 0;
1442        if (parsePtr->numWords == 3) {
1443            incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1444            if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1445                char *word = incrTokenPtr[1].start;
1446                int numBytes = incrTokenPtr[1].size;
1447                char savedChar = word[numBytes];
1448                long n;
1449            
1450                /*
1451                 * Note there is a danger that modifying the string could have
1452                 * undesirable side effects.  In this case, TclLooksLikeInt and
1453                 * TclGetLong do not have any dependencies on shared strings so we
1454                 * should be safe.
1455                 */
1456    
1457                word[numBytes] = '\0';
1458                if (TclLooksLikeInt(word, numBytes)
1459                        && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) {
1460                    if ((-127 <= n) && (n <= 127)) {
1461                        haveImmValue = 1;
1462                        immValue = n;
1463                    }
1464                }
1465                word[numBytes] = savedChar;
1466                if (!haveImmValue) {
1467                    TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes,
1468                           /*onHeap*/ 0), envPtr);
1469                    maxDepth += 1;
1470                }
1471            } else {
1472                code = TclCompileTokens(interp, incrTokenPtr+1,
1473                        incrTokenPtr->numComponents, envPtr);
1474                if (code != TCL_OK) {
1475                    if (code == TCL_ERROR) {
1476                        Tcl_AddObjErrorInfo(interp,
1477                                "\n    (increment expression)", -1);
1478                    }
1479                    goto done;
1480                }
1481                maxDepth += envPtr->maxStackDepth;
1482            }
1483        } else {                    /* no incr amount given so use 1 */
1484            haveImmValue = 1;
1485            immValue = 1;
1486        }
1487        
1488        /*
1489         * Emit the instruction to increment the variable.
1490         */
1491    
1492        if (name != NULL) {
1493            if (elName == NULL) {
1494                if (localIndex >= 0) {
1495                    if (haveImmValue) {
1496                        TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex,
1497                                        envPtr);
1498                        TclEmitInt1(immValue, envPtr);
1499                    } else {
1500                        TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
1501                    }
1502                } else {
1503                    if (haveImmValue) {
1504                        TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue,
1505                                       envPtr);
1506                    } else {
1507                        TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
1508                    }
1509                }
1510            } else {
1511                if (localIndex >= 0) {
1512                    if (haveImmValue) {
1513                        TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex,
1514                                        envPtr);
1515                        TclEmitInt1(immValue, envPtr);
1516                    } else {
1517                        TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
1518                    }
1519                } else {
1520                    if (haveImmValue) {
1521                        TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue,
1522                                       envPtr);
1523                    } else {
1524                        TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
1525                    }
1526                }
1527            }
1528        } else {                    /* non-simple variable name */
1529            if (haveImmValue) {
1530                TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
1531            } else {
1532                TclEmitOpcode(INST_INCR_STK, envPtr);
1533            }
1534        }
1535            
1536        done:
1537        if (gotElemParse) {
1538            Tcl_FreeParse(&elemParse);
1539        }
1540        envPtr->maxStackDepth = maxDepth;
1541        return code;
1542    }
1543    
1544    /*
1545     *----------------------------------------------------------------------
1546     *
1547     * TclCompileSetCmd --
1548     *
1549     *      Procedure called to compile the "set" command.
1550     *
1551     * Results:
1552     *      The return value is a standard Tcl result, which is normally TCL_OK
1553     *      unless there was an error while parsing string. If an error occurs
1554     *      then the interpreter's result contains a standard error message. If
1555     *      complation fails because the set command requires a second level of
1556     *      substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
1557     *      set command should be compiled "out of line" by emitting code to
1558     *      invoke its command procedure (Tcl_SetCmd) at runtime.
1559     *
1560     *      envPtr->maxStackDepth is updated with the maximum number of stack
1561     *      elements needed to execute the incr command.
1562     *
1563     * Side effects:
1564     *      Instructions are added to envPtr to execute the "set" command
1565     *      at runtime.
1566     *
1567     *----------------------------------------------------------------------
1568     */
1569    
1570    int
1571    TclCompileSetCmd(interp, parsePtr, envPtr)
1572        Tcl_Interp *interp;         /* Used for error reporting. */
1573        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
1574                                     * command created by Tcl_ParseCommand. */
1575        CompileEnv *envPtr;         /* Holds resulting instructions. */
1576    {
1577        Tcl_Token *varTokenPtr, *valueTokenPtr;
1578        Tcl_Parse elemParse;
1579        int gotElemParse = 0;
1580        register char *p;
1581        char *name, *elName;
1582        int nameChars, elNameChars;
1583        register int i, n;
1584        int isAssignment, simpleVarName, localIndex, numWords;
1585        int maxDepth = 0;
1586        int code = TCL_OK;
1587    
1588        envPtr->maxStackDepth = 0;
1589        numWords = parsePtr->numWords;
1590        if ((numWords != 2) && (numWords != 3)) {
1591            Tcl_ResetResult(interp);
1592            Tcl_AppendToObj(Tcl_GetObjResult(interp),
1593                    "wrong # args: should be \"set varName ?newValue?\"", -1);
1594            return TCL_ERROR;
1595        }
1596        isAssignment = (numWords == 3);
1597    
1598        /*
1599         * Decide if we can use a frame slot for the var/array name or if we
1600         * need to emit code to compute and push the name at runtime. We use a
1601         * frame slot (entry in the array of local vars) if we are compiling a
1602         * procedure body and if the name is simple text that does not include
1603         * namespace qualifiers.
1604         */
1605    
1606        simpleVarName = 0;
1607        name = elName = NULL;
1608        nameChars = elNameChars = 0;
1609        localIndex = -1;
1610    
1611        varTokenPtr = parsePtr->tokenPtr
1612                + (parsePtr->tokenPtr->numComponents + 1);
1613        /*
1614         * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
1615         * curly braces surround the variable name.
1616         * This really matters for array elements to handle things like
1617         *    set {x($foo)} 5
1618         * which raises an undefined var error if we are not careful here.
1619         * This goes with the hack in TclCompileIncrCmd.
1620         */
1621        if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
1622                (varTokenPtr->start[0] != '{')) {
1623            simpleVarName = 1;
1624    
1625            name = varTokenPtr[1].start;
1626            nameChars = varTokenPtr[1].size;
1627            /* last char is ')' => potential array reference */
1628            if ( *(name + nameChars - 1) == ')') {
1629                for (i = 0, p = name;  i < nameChars;  i++, p++) {
1630                    if (*p == '(') {
1631                        elName = p + 1;
1632                        elNameChars = nameChars - i - 2;
1633                        nameChars = i ;
1634                        break;
1635                    }
1636                }
1637            }
1638    
1639            /*
1640             * If elName contains any double quotes ("), we can't inline
1641             * compile the element script using the replace '()' by '"'
1642             * technique below.
1643             */
1644    
1645            for (i = 0, p = elName;  i < elNameChars;  i++, p++) {
1646                if (*p == '"') {
1647                    simpleVarName = 0;
1648                    break;
1649                }
1650            }
1651        } else if (((n = varTokenPtr->numComponents) > 1)
1652                && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
1653                && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
1654                && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
1655            simpleVarName = 0;
1656    
1657            /*
1658             * Check for parentheses inside first token
1659             */
1660            for (i = 0, p = varTokenPtr[1].start;
1661                 i < varTokenPtr[1].size; i++, p++) {
1662                if (*p == '(') {
1663                    simpleVarName = 1;
1664                    break;
1665                }
1666            }
1667            if (simpleVarName) {
1668                name = varTokenPtr[1].start;
1669                nameChars = p - varTokenPtr[1].start;
1670                elName = p + 1;
1671                elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
1672    
1673                /*
1674                 * If elName contains any double quotes ("), we can't inline
1675                 * compile the element script using the replace '()' by '"'
1676                 * technique below.
1677                 */
1678    
1679                for (i = 0, p = elName;  i < elNameChars;  i++, p++) {
1680                    if (*p == '"') {
1681                        simpleVarName = 0;
1682                        break;
1683                    }
1684                }
1685            }
1686        }
1687    
1688        if (simpleVarName) {
1689            /*
1690             * See whether name has any namespace separators (::'s).
1691             */
1692    
1693            int hasNsQualifiers = 0;
1694            for (i = 0, p = name;  i < nameChars;  i++, p++) {
1695                if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
1696                    hasNsQualifiers = 1;
1697                    break;
1698                }
1699            }
1700            
1701            /*
1702             * Look up the var name's index in the array of local vars in the
1703             * proc frame. If retrieving the var's value and it doesn't already
1704             * exist, push its name and look it up at runtime.
1705             */
1706    
1707            if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
1708                localIndex = TclFindCompiledLocal(name, nameChars,
1709                        /*create*/ isAssignment,
1710                        /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
1711                        envPtr->procPtr);
1712            }
1713            if (localIndex >= 0) {
1714                maxDepth = 0;
1715            } else {
1716                TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,
1717                        /*onHeap*/ 0), envPtr);
1718                maxDepth = 1;
1719            }
1720    
1721            /*
1722             * Compile the element script, if any.
1723             */
1724            
1725            if (elName != NULL) {
1726                /*
1727                 * Temporarily replace the '(' and ')' by '"'s.
1728                 */
1729    
1730                *(elName-1) = '"';
1731                *(elName+elNameChars) = '"';
1732                code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,
1733                        /*nested*/ 0, &elemParse);
1734                *(elName-1) = '(';
1735                *(elName+elNameChars) = ')';
1736                gotElemParse = 1;
1737                if ((code != TCL_OK) || (elemParse.numWords > 1)) {
1738                    char buffer[160];
1739                    sprintf(buffer, "\n    (parsing index for array \"%.*s\")",
1740                            TclMin(nameChars, 100), name);
1741                    Tcl_AddObjErrorInfo(interp, buffer, -1);
1742                    code = TCL_ERROR;
1743                    goto done;
1744                } else if (elemParse.numWords == 1) {
1745                    code = TclCompileTokens(interp, elemParse.tokenPtr+1,
1746                            elemParse.tokenPtr->numComponents, envPtr);
1747                    if (code != TCL_OK) {
1748                        goto done;
1749                    }
1750                    maxDepth += envPtr->maxStackDepth;
1751                } else {
1752                    TclEmitPush(TclRegisterLiteral(envPtr, "", 0,
1753                            /*alreadyAlloced*/ 0), envPtr);
1754                    maxDepth += 1;
1755                }
1756            }
1757        } else {
1758            /*
1759             * The var name isn't simple: compile and push it.
1760             */
1761    
1762            code = TclCompileTokens(interp, varTokenPtr+1,
1763                    varTokenPtr->numComponents, envPtr);
1764            if (code != TCL_OK) {
1765                goto done;
1766            }
1767            maxDepth += envPtr->maxStackDepth;
1768        }
1769            
1770        /*
1771         * If we are doing an assignment, push the new value.
1772         */
1773        
1774        if (isAssignment) {
1775            valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1776            if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1777                TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start,
1778                        valueTokenPtr[1].size, /*onHeap*/ 0), envPtr);
1779                maxDepth += 1;
1780            } else {
1781                code = TclCompileTokens(interp, valueTokenPtr+1,
1782                        valueTokenPtr->numComponents, envPtr);
1783                if (code != TCL_OK) {
1784                    goto done;
1785                }
1786                maxDepth += envPtr->maxStackDepth;
1787            }
1788        }
1789            
1790        /*
1791         * Emit instructions to set/get the variable.
1792         */
1793    
1794        if (simpleVarName) {
1795            if (elName == NULL) {
1796                if (localIndex >= 0) {
1797                    if (localIndex <= 255) {
1798                        TclEmitInstInt1((isAssignment?
1799                                INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
1800                                localIndex, envPtr);
1801                    } else {
1802                        TclEmitInstInt4((isAssignment?
1803                                INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
1804                                localIndex, envPtr);
1805                    }
1806                } else {
1807                    TclEmitOpcode((isAssignment?
1808                            INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
1809                            envPtr);
1810                }
1811            } else {
1812                if (localIndex >= 0) {
1813                    if (localIndex <= 255) {
1814                        TclEmitInstInt1((isAssignment?
1815                                INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
1816                                localIndex, envPtr);
1817                    } else {
1818                        TclEmitInstInt4((isAssignment?
1819                                INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
1820                                localIndex, envPtr);
1821                    }
1822                } else {
1823                    TclEmitOpcode((isAssignment?
1824                            INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
1825                            envPtr);
1826                }
1827            }
1828        } else {
1829            TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK),
1830                    envPtr);
1831        }
1832            
1833        done:
1834        if (gotElemParse) {
1835            Tcl_FreeParse(&elemParse);
1836        }
1837        envPtr->maxStackDepth = maxDepth;
1838        return code;
1839    }
1840    
1841    /*
1842     *----------------------------------------------------------------------
1843     *
1844     * TclCompileWhileCmd --
1845     *
1846     *      Procedure called to compile the "while" command.
1847     *
1848     * Results:
1849     *      The return value is a standard Tcl result, which is TCL_OK if
1850     *      compilation was successful. If an error occurs then the
1851     *      interpreter's result contains a standard error message and TCL_ERROR
1852     *      is returned. If compilation failed because the command is too
1853     *      complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
1854     *      indicating that the while command should be compiled "out of line"
1855     *      by emitting code to invoke its command procedure at runtime.
1856     *
1857     *      envPtr->maxStackDepth is updated with the maximum number of stack
1858     *      elements needed to execute the "while" command.
1859     *
1860     * Side effects:
1861     *      Instructions are added to envPtr to execute the "while" command
1862     *      at runtime.
1863     *
1864     *----------------------------------------------------------------------
1865     */
1866    
1867    int
1868    TclCompileWhileCmd(interp, parsePtr, envPtr)
1869        Tcl_Interp *interp;         /* Used for error reporting. */
1870        Tcl_Parse *parsePtr;        /* Points to a parse structure for the
1871                                     * command created by Tcl_ParseCommand. */
1872        CompileEnv *envPtr;         /* Holds resulting instructions. */
1873    {
1874        Tcl_Token *testTokenPtr, *bodyTokenPtr;
1875        JumpFixup jumpFalseFixup;
1876        unsigned char *jumpPc;
1877        int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset;
1878        int range, maxDepth, code;
1879        char buffer[32 + TCL_INTEGER_SPACE];
1880    
1881        envPtr->maxStackDepth = 0;
1882        maxDepth = 0;
1883        if (parsePtr->numWords != 3) {
1884            Tcl_ResetResult(interp);
1885            Tcl_AppendToObj(Tcl_GetObjResult(interp),
1886                    "wrong # args: should be \"while test command\"", -1);
1887            return TCL_ERROR;
1888        }
1889    
1890        /*
1891         * If the test expression requires substitutions, don't compile the
1892         * while command inline. E.g., the expression might cause the loop to
1893         * never execute or execute forever, as in "while "$x < 5" {}".
1894         */
1895    
1896        testTokenPtr = parsePtr->tokenPtr
1897                + (parsePtr->tokenPtr->numComponents + 1);
1898        if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1899            return TCL_OUT_LINE_COMPILE;
1900        }
1901    
1902        /*
1903         * Create a ExceptionRange record for the loop body. This is used to
1904         * implement break and continue.
1905         */
1906    
1907        envPtr->exceptDepth++;
1908        envPtr->maxExceptDepth =
1909            TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
1910        range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
1911        envPtr->exceptArrayPtr[range].continueOffset =
1912                (envPtr->codeNext - envPtr->codeStart);
1913    
1914        /*
1915         * Compile the test expression then emit the conditional jump that
1916         * terminates the while. We already know it's a simple word.
1917         */
1918    
1919        testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1920        envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
1921        code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
1922        if (code != TCL_OK) {
1923            if (code == TCL_ERROR) {
1924                Tcl_AddObjErrorInfo(interp,
1925                        "\n    (\"while\" test expression)", -1);
1926            }
1927            goto error;
1928        }
1929        maxDepth = envPtr->maxStackDepth;
1930        TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
1931        
1932        /*
1933         * Compile the loop body.
1934         */
1935    
1936        bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
1937        envPtr->exceptArrayPtr[range].codeOffset =
1938                (envPtr->codeNext - envPtr->codeStart);
1939        code = TclCompileCmdWord(interp, bodyTokenPtr+1,
1940                bodyTokenPtr->numComponents, envPtr);
1941        if (code != TCL_OK) {
1942            if (code == TCL_ERROR) {
1943                sprintf(buffer, "\n    (\"while\" body line %d)",
1944                        interp->errorLine);
1945                Tcl_AddObjErrorInfo(interp, buffer, -1);
1946            }
1947            goto error;
1948        }
1949        maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
1950        envPtr->exceptArrayPtr[range].numCodeBytes =
1951                (envPtr->codeNext - envPtr->codeStart)
1952                - envPtr->exceptArrayPtr[range].codeOffset;
1953        TclEmitOpcode(INST_POP, envPtr);
1954            
1955        /*
1956         * Jump back to the test at the top of the loop. Generate a 4 byte jump
1957         * if the distance to the test is > 120 bytes. This is conservative and
1958         * ensures that we won't have to replace this jump if we later need to
1959         * replace the ifFalse jump with a 4 byte jump.
1960         */
1961    
1962        jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
1963        jumpBackDist = (jumpBackOffset - testCodeOffset);
1964        if (jumpBackDist > 120) {
1965            TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
1966        } else {
1967            TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
1968        }
1969    
1970        /*
1971         * Fix the target of the jumpFalse after the test.
1972         */
1973    
1974        jumpDist = (envPtr->codeNext - envPtr->codeStart)
1975                - jumpFalseFixup.codeOffset;
1976        if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
1977            /*
1978             * Update the loop body's starting PC offset since it moved down.
1979             */
1980    
1981            envPtr->exceptArrayPtr[range].codeOffset += 3;
1982    
1983            /*
1984             * Update the jump back to the test at the top of the loop since it
1985             * also moved down 3 bytes.
1986             */
1987    
1988            jumpBackOffset += 3;
1989            jumpPc = (envPtr->codeStart + jumpBackOffset);
1990            jumpBackDist += 3;
1991            if (jumpBackDist > 120) {
1992                TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
1993            } else {
1994                TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
1995            }
1996        }
1997    
1998        /*
1999         * Set the loop's break target.
2000         */
2001    
2002        envPtr->exceptArrayPtr[range].breakOffset =
2003                (envPtr->codeNext - envPtr->codeStart);
2004        
2005        /*
2006         * The while command's result is an empty string.
2007         */
2008    
2009        TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
2010        if (maxDepth == 0) {
2011            maxDepth = 1;
2012        }
2013        envPtr->maxStackDepth = maxDepth;
2014        envPtr->exceptDepth--;
2015        return TCL_OK;
2016    
2017        error:
2018        envPtr->maxStackDepth = maxDepth;
2019        envPtr->exceptDepth--;
2020        return code;
2021    }
2022    
2023    /* End of tclcompcmds.c */

Legend:
Removed from v.44  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25