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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25