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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25