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

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

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

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

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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25