/[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 42 - (show annotations) (download)
Fri Oct 14 01:50:00 2016 UTC (8 years ago) by dashley
Original Path: projs/trunk/shared_source/tcl_base/tclcompcmds.c
File MIME type: text/plain
File size: 63419 byte(s)
Move shared source code to commonize.
1 /* $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