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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25