Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclCompCmds.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

File size: 177.9 KB
Line 
1/*
2 * tclCompCmds.c --
3 *
4 *      This file contains compilation procedures that compile various Tcl
5 *      commands into a sequence of instructions ("bytecodes").
6 *
7 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
8 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
9 * Copyright (c) 2002 ActiveState Corporation.
10 * Copyright (c) 2004-2006 by Donal K. Fellows.
11 *
12 * See the file "license.terms" for information on usage and redistribution of
13 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
14 *
15 * RCS: @(#) $Id: tclCompCmds.c,v 1.143 2008/03/16 17:00:43 dkf Exp $
16 */
17
18#include "tclInt.h"
19#include "tclCompile.h"
20
21/*
22 * Macro that encapsulates an efficiency trick that avoids a function call for
23 * the simplest of compiles. The ANSI C "prototype" for this macro is:
24 *
25 * static void          CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
26 *                          Tcl_Interp *interp, int word);
27 */
28
29#define CompileWord(envPtr, tokenPtr, interp, word) \
30    if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
31        TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
32                (tokenPtr)[1].size), (envPtr)); \
33    } else { \
34        envPtr->line = mapPtr->loc[eclIndex].line[word]; \
35        TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
36                (envPtr)); \
37    }
38
39/*
40 * TIP #280: Remember the per-word line information of the current command. An
41 * index is used instead of a pointer as recursive compilation may reallocate,
42 * i.e. move, the array. This is also the reason to save the nuloc now, it may
43 * change during the course of the function.
44 *
45 * Macro to encapsulate the variable definition and setup.
46 */
47
48#define DefineLineInformation \
49    ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
50    int eclIndex = mapPtr->nuloc - 1
51
52/*
53 * Convenience macro for use when compiling bodies of commands. The ANSI C
54 * "prototype" for this macro is:
55 *
56 * static void          CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
57 *                          Tcl_Interp *interp);
58 */
59
60#define CompileBody(envPtr, tokenPtr, interp) \
61    TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
62            (envPtr))
63
64/*
65 * Convenience macro for use when compiling tokens to be pushed. The ANSI C
66 * "prototype" for this macro is:
67 *
68 * static void          CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr,
69 *                          Tcl_Interp *interp);
70 */
71
72#define CompileTokens(envPtr, tokenPtr, interp) \
73    TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
74            (envPtr));
75/*
76 * Convenience macro for use when pushing literals. The ANSI C "prototype" for
77 * this macro is:
78 *
79 * static void          PushLiteral(CompileEnv *envPtr,
80 *                          const char *string, int length);
81 */
82
83#define PushLiteral(envPtr, string, length) \
84    TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
85
86/*
87 * Macro to advance to the next token; it is more mnemonic than the address
88 * arithmetic that it replaces. The ANSI C "prototype" for this macro is:
89 *
90 * static Tcl_Token *   TokenAfter(Tcl_Token *tokenPtr);
91 */
92
93#define TokenAfter(tokenPtr) \
94    ((tokenPtr) + ((tokenPtr)->numComponents + 1))
95
96/*
97 * Macro to get the offset to the next instruction to be issued. The ANSI C
98 * "prototype" for this macro is:
99 *
100 * static int   CurrentOffset(CompileEnv *envPtr);
101 */
102
103#define CurrentOffset(envPtr) \
104    ((envPtr)->codeNext - (envPtr)->codeStart)
105
106/*
107 * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
108 * maximal depth of nested CATCH ranges in order to alloc runtime
109 * memory. These macros should compute precisely that? OTOH, the nesting depth
110 * of LOOP ranges is an interesting datum for debugging purposes, and that is
111 * what we compute now.
112 *
113 * static int   DeclareExceptionRange(CompileEnv *envPtr, int type);
114 * static int   ExceptionRangeStarts(CompileEnv *envPtr, int index);
115 * static void  ExceptionRangeEnds(CompileEnv *envPtr, int index);
116 * static void  ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
117 */
118
119#define DeclareExceptionRange(envPtr, type) \
120    (TclCreateExceptRange((type), (envPtr)))
121#define ExceptionRangeStarts(envPtr, index) \
122    (((envPtr)->exceptDepth++), \
123    ((envPtr)->maxExceptDepth = \
124            TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
125    ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)))
126#define ExceptionRangeEnds(envPtr, index) \
127    (((envPtr)->exceptDepth--), \
128    ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
129        CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset))
130#define ExceptionRangeTarget(envPtr, index, targetType) \
131    ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
132
133/*
134 * Prototypes for procedures defined later in this file:
135 */
136
137static ClientData       DupDictUpdateInfo(ClientData clientData);
138static void             FreeDictUpdateInfo(ClientData clientData);
139static void             PrintDictUpdateInfo(ClientData clientData,
140                            Tcl_Obj *appendObj, ByteCode *codePtr,
141                            unsigned int pcOffset);
142static ClientData       DupForeachInfo(ClientData clientData);
143static void             FreeForeachInfo(ClientData clientData);
144static void             PrintForeachInfo(ClientData clientData,
145                            Tcl_Obj *appendObj, ByteCode *codePtr,
146                            unsigned int pcOffset);
147static ClientData       DupJumptableInfo(ClientData clientData);
148static void             FreeJumptableInfo(ClientData clientData);
149static void             PrintJumptableInfo(ClientData clientData,
150                            Tcl_Obj *appendObj, ByteCode *codePtr,
151                            unsigned int pcOffset);
152static int              PushVarName(Tcl_Interp *interp,
153                            Tcl_Token *varTokenPtr, CompileEnv *envPtr,
154                            int flags, int *localIndexPtr,
155                            int *simpleVarNamePtr, int *isScalarPtr, int line);
156static int              CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
157                            Tcl_Parse *parsePtr, const char *identity,
158                            int instruction, CompileEnv *envPtr);
159static int              CompileComparisonOpCmd(Tcl_Interp *interp,
160                            Tcl_Parse *parsePtr, int instruction,
161                            CompileEnv *envPtr);
162static int              CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
163                            Tcl_Parse *parsePtr, int instruction,
164                            CompileEnv *envPtr);
165static int              CompileUnaryOpCmd(Tcl_Interp *interp,
166                            Tcl_Parse *parsePtr, int instruction,
167                            CompileEnv *envPtr);
168static void             CompileReturnInternal(CompileEnv *envPtr,
169                            unsigned char op, int code, int level,
170                            Tcl_Obj *returnOpts);
171
172/*
173 * Flags bits used by PushVarName.
174 */
175
176#define TCL_CREATE_VAR     1    /* Create a compiled local if none is found */
177#define TCL_NO_LARGE_INDEX 2    /* Do not return localIndex value > 255 */
178
179/*
180 * The structures below define the AuxData types defined in this file.
181 */
182
183AuxDataType tclForeachInfoType = {
184    "ForeachInfo",              /* name */
185    DupForeachInfo,             /* dupProc */
186    FreeForeachInfo,            /* freeProc */
187    PrintForeachInfo            /* printProc */
188};
189
190AuxDataType tclJumptableInfoType = {
191    "JumptableInfo",            /* name */
192    DupJumptableInfo,           /* dupProc */
193    FreeJumptableInfo,          /* freeProc */
194    PrintJumptableInfo          /* printProc */
195};
196
197AuxDataType tclDictUpdateInfoType = {
198    "DictUpdateInfo",           /* name */
199    DupDictUpdateInfo,          /* dupProc */
200    FreeDictUpdateInfo,         /* freeProc */
201    PrintDictUpdateInfo         /* printProc */
202};
203
204/*
205 *----------------------------------------------------------------------
206 *
207 * TclCompileAppendCmd --
208 *
209 *      Procedure called to compile the "append" command.
210 *
211 * Results:
212 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
213 *      evaluation to runtime.
214 *
215 * Side effects:
216 *      Instructions are added to envPtr to execute the "append" command at
217 *      runtime.
218 *
219 *----------------------------------------------------------------------
220 */
221
222int
223TclCompileAppendCmd(
224    Tcl_Interp *interp,         /* Used for error reporting. */
225    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
226                                 * created by Tcl_ParseCommand. */
227    Command *cmdPtr,            /* Points to defintion of command being
228                                 * compiled. */
229    CompileEnv *envPtr)         /* Holds resulting instructions. */
230{
231    Tcl_Token *varTokenPtr, *valueTokenPtr;
232    int simpleVarName, isScalar, localIndex, numWords;
233    DefineLineInformation;      /* TIP #280 */
234
235    numWords = parsePtr->numWords;
236    if (numWords == 1) {
237        return TCL_ERROR;
238    } else if (numWords == 2) {
239        /*
240         * append varName == set varName
241         */
242
243        return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr);
244    } else if (numWords > 3) {
245        /*
246         * APPEND instructions currently only handle one value.
247         */
248
249        return TCL_ERROR;
250    }
251
252    /*
253     * Decide if we can use a frame slot for the var/array name or if we need
254     * to emit code to compute and push the name at runtime. We use a frame
255     * slot (entry in the array of local vars) if we are compiling a procedure
256     * body and if the name is simple text that does not include namespace
257     * qualifiers.
258     */
259
260    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
261
262    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
263                &localIndex, &simpleVarName, &isScalar,
264                mapPtr->loc[eclIndex].line[1]);
265
266    /*
267     * We are doing an assignment, otherwise TclCompileSetCmd was called, so
268     * push the new value. This will need to be extended to push a value for
269     * each argument.
270     */
271
272    if (numWords > 2) {
273        valueTokenPtr = TokenAfter(varTokenPtr);
274        CompileWord(envPtr, valueTokenPtr, interp, 2);
275    }
276
277    /*
278     * Emit instructions to set/get the variable.
279     */
280
281    if (simpleVarName) {
282        if (isScalar) {
283            if (localIndex < 0) {
284                TclEmitOpcode(INST_APPEND_STK, envPtr);
285            } else if (localIndex <= 255) {
286                TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
287            } else {
288                TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
289            }
290        } else {
291            if (localIndex < 0) {
292                TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
293            } else if (localIndex <= 255) {
294                TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
295            } else {
296                TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
297            }
298        }
299    } else {
300        TclEmitOpcode(INST_APPEND_STK, envPtr);
301    }
302
303    return TCL_OK;
304}
305
306/*
307 *----------------------------------------------------------------------
308 *
309 * TclCompileBreakCmd --
310 *
311 *      Procedure called to compile the "break" command.
312 *
313 * Results:
314 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
315 *      evaluation to runtime.
316 *
317 * Side effects:
318 *      Instructions are added to envPtr to execute the "break" command at
319 *      runtime.
320 *
321 *----------------------------------------------------------------------
322 */
323
324int
325TclCompileBreakCmd(
326    Tcl_Interp *interp,         /* Used for error reporting. */
327    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
328                                 * created by Tcl_ParseCommand. */
329    Command *cmdPtr,            /* Points to defintion of command being
330                                 * compiled. */
331    CompileEnv *envPtr)         /* Holds resulting instructions. */
332{
333    if (parsePtr->numWords != 1) {
334        return TCL_ERROR;
335    }
336
337    /*
338     * Emit a break instruction.
339     */
340
341    TclEmitOpcode(INST_BREAK, envPtr);
342    return TCL_OK;
343}
344
345/*
346 *----------------------------------------------------------------------
347 *
348 * TclCompileCatchCmd --
349 *
350 *      Procedure called to compile the "catch" command.
351 *
352 * Results:
353 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
354 *      evaluation to runtime.
355 *
356 * Side effects:
357 *      Instructions are added to envPtr to execute the "catch" command at
358 *      runtime.
359 *
360 *----------------------------------------------------------------------
361 */
362
363int
364TclCompileCatchCmd(
365    Tcl_Interp *interp,         /* Used for error reporting. */
366    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
367                                 * created by Tcl_ParseCommand. */
368    Command *cmdPtr,            /* Points to defintion of command being
369                                 * compiled. */
370    CompileEnv *envPtr)         /* Holds resulting instructions. */
371{
372    JumpFixup jumpFixup;
373    Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
374    const char *name;
375    int resultIndex, optsIndex, nameChars, range;
376    int savedStackDepth = envPtr->currStackDepth;
377    DefineLineInformation;      /* TIP #280 */
378
379    /*
380     * If syntax does not match what we expect for [catch], do not compile.
381     * Let runtime checks determine if syntax has changed.
382     */
383
384    if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) {
385        return TCL_ERROR;
386    }
387
388    /*
389     * If variables were specified and the catch command is at global level
390     * (not in a procedure), don't compile it inline: the payoff is too small.
391     */
392
393    if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) {
394        return TCL_ERROR;
395    }
396
397    /*
398     * Make sure the variable names, if any, have no substitutions and just
399     * refer to local scalars.
400     */
401
402    resultIndex = optsIndex = -1;
403    cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);
404    if (parsePtr->numWords >= 3) {
405        resultNameTokenPtr = TokenAfter(cmdTokenPtr);
406        /* DGP */
407        if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
408            return TCL_ERROR;
409        }
410
411        name = resultNameTokenPtr[1].start;
412        nameChars = resultNameTokenPtr[1].size;
413        if (!TclIsLocalScalar(name, nameChars)) {
414            return TCL_ERROR;
415        }
416        resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
417                resultNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
418
419        /* DKF */
420        if (parsePtr->numWords == 4) {
421            optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
422            if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
423                return TCL_ERROR;
424            }
425            name = optsNameTokenPtr[1].start;
426            nameChars = optsNameTokenPtr[1].size;
427            if (!TclIsLocalScalar(name, nameChars)) {
428                return TCL_ERROR;
429            }
430            optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
431                    optsNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
432        }
433    }
434
435    /*
436     * We will compile the catch command. Emit a beginCatch instruction at the
437     * start of the catch body: the subcommand it controls.
438     */
439
440    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
441    TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
442
443    /*
444     * If the body is a simple word, compile the instructions to eval it.
445     * Otherwise, compile instructions to substitute its text without
446     * catching, a catch instruction that resets the stack to what it was
447     * before substituting the body, and then an instruction to eval the body.
448     * Care has to be taken to register the correct startOffset for the catch
449     * range so that errors in the substitution are not catched [Bug 219184]
450     */
451
452    envPtr->line = mapPtr->loc[eclIndex].line[1];
453    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
454        ExceptionRangeStarts(envPtr, range);
455        CompileBody(envPtr, cmdTokenPtr, interp);
456        ExceptionRangeEnds(envPtr, range);
457    } else {
458        CompileTokens(envPtr, cmdTokenPtr, interp);
459        ExceptionRangeStarts(envPtr, range);
460        TclEmitOpcode(INST_EVAL_STK, envPtr);
461        ExceptionRangeEnds(envPtr, range);
462    }
463
464    /*
465     * The "no errors" epilogue code: store the body's result into the
466     * variable (if any), push "0" (TCL_OK) as the catch's "no error" result,
467     * and jump around the "error case" code. Note that we issue the push of
468     * the return options first so that if alterations happen to the current
469     * interpreter state during the writing of the variable, we won't see
470     * them; this results in a slightly complex instruction issuing flow
471     * (can't exchange, only duplicate and pop).
472     */
473
474    if (resultIndex != -1) {
475        if (optsIndex != -1) {
476            TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
477            TclEmitInstInt4(INST_OVER, 1, envPtr);
478        }
479        if (resultIndex <= 255) {
480            TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
481        } else {
482            TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
483        }
484        if (optsIndex != -1) {
485            TclEmitOpcode(INST_POP, envPtr);
486            if (optsIndex <= 255) {
487                TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
488            } else {
489                TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
490            }
491            TclEmitOpcode(INST_POP, envPtr);
492        }
493    }
494    TclEmitOpcode(INST_POP, envPtr);
495    PushLiteral(envPtr, "0", 1);
496    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
497
498    /*
499     * The "error case" code: store the body's result into the variable (if
500     * any), then push the error result code. The initial PC offset here is
501     * the catch's error target. Note that if we are saving the return
502     * options, we do that first so the preservation cannot get affected by
503     * any intermediate result handling.
504     */
505
506    envPtr->currStackDepth = savedStackDepth;
507    ExceptionRangeTarget(envPtr, range, catchOffset);
508    if (resultIndex != -1) {
509        if (optsIndex != -1) {
510            TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
511        }
512        TclEmitOpcode(INST_PUSH_RESULT, envPtr);
513        if (resultIndex <= 255) {
514            TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
515        } else {
516            TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
517        }
518        TclEmitOpcode(INST_POP, envPtr);
519        if (optsIndex != -1) {
520            if (optsIndex <= 255) {
521                TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
522            } else {
523                TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
524            }
525            TclEmitOpcode(INST_POP, envPtr);
526        }
527    }
528    TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
529
530    /*
531     * Update the target of the jump after the "no errors" code, then emit an
532     * endCatch instruction at the end of the catch command.
533     */
534
535    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
536        Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
537                CurrentOffset(envPtr) - jumpFixup.codeOffset);
538    }
539    TclEmitOpcode(INST_END_CATCH, envPtr);
540
541    envPtr->currStackDepth = savedStackDepth + 1;
542    return TCL_OK;
543}
544
545/*
546 *----------------------------------------------------------------------
547 *
548 * TclCompileContinueCmd --
549 *
550 *      Procedure called to compile the "continue" command.
551 *
552 * Results:
553 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
554 *      evaluation to runtime.
555 *
556 * Side effects:
557 *      Instructions are added to envPtr to execute the "continue" command at
558 *      runtime.
559 *
560 *----------------------------------------------------------------------
561 */
562
563int
564TclCompileContinueCmd(
565    Tcl_Interp *interp,         /* Used for error reporting. */
566    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
567                                 * created by Tcl_ParseCommand. */
568    Command *cmdPtr,            /* Points to defintion of command being
569                                 * compiled. */
570    CompileEnv *envPtr)         /* Holds resulting instructions. */
571{
572    /*
573     * There should be no argument after the "continue".
574     */
575
576    if (parsePtr->numWords != 1) {
577        return TCL_ERROR;
578    }
579
580    /*
581     * Emit a continue instruction.
582     */
583
584    TclEmitOpcode(INST_CONTINUE, envPtr);
585    return TCL_OK;
586}
587
588/*
589 *----------------------------------------------------------------------
590 *
591 * TclCompileDict*Cmd --
592 *
593 *      Functions called to compile "dict" sucommands.
594 *
595 * Results:
596 *      All return TCL_OK for a successful compile, and TCL_ERROR to defer
597 *      evaluation to runtime.
598 *
599 * Side effects:
600 *      Instructions are added to envPtr to execute the "dict" subcommand at
601 *      runtime.
602 *
603 * Notes:
604 *      The following commands are in fairly common use and are possibly worth
605 *      bytecoding:
606 *              dict append
607 *              dict create     [*]
608 *              dict exists     [*]
609 *              dict for
610 *              dict get        [*]
611 *              dict incr
612 *              dict keys       [*]
613 *              dict lappend
614 *              dict set
615 *              dict unset
616 *
617 *      In practice, those that are pure-value operators (marked with [*]) can
618 *      probably be left alone (except perhaps [dict get] which is very very
619 *      common) and [dict update] should be considered instead (really big
620 *      win!)
621 *
622 *----------------------------------------------------------------------
623 */
624
625int
626TclCompileDictSetCmd(
627    Tcl_Interp *interp,         /* Used for looking up stuff. */
628    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
629                                 * created by Tcl_ParseCommand. */
630    Command *cmdPtr,            /* Points to defintion of command being
631                                 * compiled. */
632    CompileEnv *envPtr)         /* Holds resulting instructions. */
633{
634    Tcl_Token *tokenPtr;
635    int numWords, i;
636    Proc *procPtr = envPtr->procPtr;
637    DefineLineInformation;      /* TIP #280 */
638    Tcl_Token *varTokenPtr;
639    int dictVarIndex, nameChars;
640    const char *name;
641
642    /*
643     * There must be at least one argument after the command.
644     */
645
646    if (parsePtr->numWords < 4 || procPtr == NULL) {
647        return TCL_ERROR;
648    }
649
650    /*
651     * The dictionary variable must be a local scalar that is knowable at
652     * compile time; anything else exceeds the complexity of the opcode. So
653     * discover what the index is.
654     */
655
656    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
657    if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
658        return TCL_ERROR;
659    }
660    name = varTokenPtr[1].start;
661    nameChars = varTokenPtr[1].size;
662    if (!TclIsLocalScalar(name, nameChars)) {
663        return TCL_ERROR;
664    }
665    dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
666
667    /*
668     * Remaining words (key path and value to set) can be handled normally.
669     */
670
671    tokenPtr = TokenAfter(varTokenPtr);
672    numWords = parsePtr->numWords-1;
673    for (i=1 ; i<numWords ; i++) {
674        CompileWord(envPtr, tokenPtr, interp, i);
675        tokenPtr = TokenAfter(tokenPtr);
676    }
677
678    /*
679     * Now emit the instruction to do the dict manipulation.
680     */
681
682    TclEmitInstInt4( INST_DICT_SET, numWords-2,         envPtr);
683    TclEmitInt4(     dictVarIndex,                      envPtr);
684    return TCL_OK;
685}
686
687int
688TclCompileDictIncrCmd(
689    Tcl_Interp *interp,         /* Used for looking up stuff. */
690    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
691                                 * created by Tcl_ParseCommand. */
692    Command *cmdPtr,            /* Points to defintion of command being
693                                 * compiled. */
694    CompileEnv *envPtr)         /* Holds resulting instructions. */
695{
696    Proc *procPtr = envPtr->procPtr;
697    DefineLineInformation;      /* TIP #280 */
698    Tcl_Token *varTokenPtr, *keyTokenPtr;
699    int dictVarIndex, nameChars, incrAmount;
700    const char *name;
701
702    /*
703     * There must be at least two arguments after the command.
704     */
705
706    if (parsePtr->numWords < 3 || parsePtr->numWords > 4 || procPtr == NULL) {
707        return TCL_ERROR;
708    }
709    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
710    keyTokenPtr = TokenAfter(varTokenPtr);
711
712    /*
713     * Parse the increment amount, if present.
714     */
715
716    if (parsePtr->numWords == 4) {
717        const char *word;
718        int numBytes, code;
719        Tcl_Token *incrTokenPtr;
720        Tcl_Obj *intObj;
721
722        incrTokenPtr = TokenAfter(keyTokenPtr);
723        if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
724            return TCL_ERROR;
725        }
726        word = incrTokenPtr[1].start;
727        numBytes = incrTokenPtr[1].size;
728
729        intObj = Tcl_NewStringObj(word, numBytes);
730        Tcl_IncrRefCount(intObj);
731        code = TclGetIntFromObj(NULL, intObj, &incrAmount);
732        TclDecrRefCount(intObj);
733        if (code != TCL_OK) {
734            return TCL_ERROR;
735        }
736    } else {
737        incrAmount = 1;
738    }
739
740    /*
741     * The dictionary variable must be a local scalar that is knowable at
742     * compile time; anything else exceeds the complexity of the opcode. So
743     * discover what the index is.
744     */
745
746    if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
747        return TCL_ERROR;
748    }
749    name = varTokenPtr[1].start;
750    nameChars = varTokenPtr[1].size;
751    if (!TclIsLocalScalar(name, nameChars)) {
752        return TCL_ERROR;
753    }
754    dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
755
756    /*
757     * Emit the key and the code to actually do the increment.
758     */
759
760    CompileWord(envPtr, keyTokenPtr, interp, 3);
761    TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount,    envPtr);
762    TclEmitInt4(     dictVarIndex,                      envPtr);
763    return TCL_OK;
764}
765
766int
767TclCompileDictGetCmd(
768    Tcl_Interp *interp,         /* Used for looking up stuff. */
769    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
770                                 * created by Tcl_ParseCommand. */
771    Command *cmdPtr,            /* Points to defintion of command being
772                                 * compiled. */
773    CompileEnv *envPtr)         /* Holds resulting instructions. */
774{
775    Tcl_Token *tokenPtr;
776    int numWords, i;
777    DefineLineInformation;      /* TIP #280 */
778
779    /*
780     * There must be at least two arguments after the command (the single-arg
781     * case is legal, but too special and magic for us to deal with here).
782     */
783
784    if (parsePtr->numWords < 3) {
785        return TCL_ERROR;
786    }
787    tokenPtr = TokenAfter(parsePtr->tokenPtr);
788    numWords = parsePtr->numWords-1;
789
790    /*
791     * Only compile this because we need INST_DICT_GET anyway.
792     */
793
794    for (i=0 ; i<numWords ; i++) {
795        CompileWord(envPtr, tokenPtr, interp, i);
796        tokenPtr = TokenAfter(tokenPtr);
797    }
798    TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
799    return TCL_OK;
800}
801
802int
803TclCompileDictForCmd(
804    Tcl_Interp *interp,         /* Used for looking up stuff. */
805    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
806                                 * created by Tcl_ParseCommand. */
807    Command *cmdPtr,            /* Points to defintion of command being
808                                 * compiled. */
809    CompileEnv *envPtr)         /* Holds resulting instructions. */
810{
811    Proc *procPtr = envPtr->procPtr;
812    DefineLineInformation;      /* TIP #280 */
813    Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
814    int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
815    int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
816    int numVars, endTargetOffset;
817    int savedStackDepth = envPtr->currStackDepth;
818                                /* Needed because jumps confuse the stack
819                                 * space calculator. */
820    const char **argv;
821    Tcl_DString buffer;
822
823    /*
824     * There must be at least three argument after the command.
825     */
826
827    if (parsePtr->numWords != 4 || procPtr == NULL) {
828        return TCL_ERROR;
829    }
830
831    varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
832    dictTokenPtr = TokenAfter(varsTokenPtr);
833    bodyTokenPtr = TokenAfter(dictTokenPtr);
834    if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
835            bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
836        return TCL_ERROR;
837    }
838
839    /*
840     * Check we've got a pair of variables and that they are local variables.
841     * Then extract their indices in the LVT.
842     */
843
844    Tcl_DStringInit(&buffer);
845    Tcl_DStringAppend(&buffer, varsTokenPtr[1].start, varsTokenPtr[1].size);
846    if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
847            &argv) != TCL_OK) {
848        Tcl_DStringFree(&buffer);
849        return TCL_ERROR;
850    }
851    Tcl_DStringFree(&buffer);
852    if (numVars != 2) {
853        ckfree((char *) argv);
854        return TCL_ERROR;
855    }
856
857    nameChars = strlen(argv[0]);
858    if (!TclIsLocalScalar(argv[0], nameChars)) {
859        ckfree((char *) argv);
860        return TCL_ERROR;
861    }
862    keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, procPtr);
863
864    nameChars = strlen(argv[1]);
865    if (!TclIsLocalScalar(argv[1], nameChars)) {
866        ckfree((char *) argv);
867        return TCL_ERROR;
868    }
869    valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, procPtr);
870    ckfree((char *) argv);
871
872    /*
873     * Allocate a temporary variable to store the iterator reference. The
874     * variable will contain a Tcl_DictSearch reference which will be
875     * allocated by INST_DICT_FIRST and disposed when the variable is unset
876     * (at which point it should also have been finished with).
877     */
878
879    infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
880
881    /*
882     * Preparation complete; issue instructions. Note that this code issues
883     * fixed-sized jumps. That simplifies things a lot!
884     *
885     * First up, get the dictionary and start the iteration. No catching of
886     * errors at this point.
887     */
888
889    CompileWord(envPtr, dictTokenPtr, interp, 3);
890    TclEmitInstInt4( INST_DICT_FIRST, infoIndex,                envPtr);
891    emptyTargetOffset = CurrentOffset(envPtr);
892    TclEmitInstInt4( INST_JUMP_TRUE4, 0,                        envPtr);
893
894    /*
895     * Now we catch errors from here on so that we can finalize the search
896     * started by Tcl_DictObjFirst above.
897     */
898
899    catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
900    TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange,             envPtr);
901    ExceptionRangeStarts(envPtr, catchRange);
902
903    /*
904     * Inside the iteration, write the loop variables.
905     */
906
907    bodyTargetOffset = CurrentOffset(envPtr);
908    TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex,           envPtr);
909    TclEmitOpcode(   INST_POP,                                  envPtr);
910    TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex,         envPtr);
911    TclEmitOpcode(   INST_POP,                                  envPtr);
912
913    /*
914     * Set up the loop exception targets.
915     */
916
917    loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
918    ExceptionRangeStarts(envPtr, loopRange);
919
920    /*
921     * Compile the loop body itself. It should be stack-neutral.
922     */
923
924    envPtr->line = mapPtr->loc[eclIndex].line[4];
925    CompileBody(envPtr, bodyTokenPtr, interp);
926    TclEmitOpcode(   INST_POP,                                  envPtr);
927
928    /*
929     * Both exception target ranges (error and loop) end here.
930     */
931
932    ExceptionRangeEnds(envPtr, loopRange);
933    ExceptionRangeEnds(envPtr, catchRange);
934
935    /*
936     * Continue (or just normally process) by getting the next pair of items
937     * from the dictionary and jumping back to the code to write them into
938     * variables if there is another pair.
939     */
940
941    ExceptionRangeTarget(envPtr, loopRange, continueOffset);
942    TclEmitInstInt4( INST_DICT_NEXT, infoIndex,                 envPtr);
943    jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
944    TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement,        envPtr);
945    TclEmitOpcode(   INST_POP,                                  envPtr);
946    TclEmitOpcode(   INST_POP,                                  envPtr);
947
948    /*
949     * Now do the final cleanup for the no-error case (this is where we break
950     * out of the loop to) by force-terminating the iteration (if not already
951     * terminated), ditching the exception info and jumping to the last
952     * instruction for this command. In theory, this could be done using the
953     * "finally" clause (next generated) but this is faster.
954     */
955
956    ExceptionRangeTarget(envPtr, loopRange, breakOffset);
957    TclEmitInstInt4( INST_DICT_DONE, infoIndex,                 envPtr);
958    TclEmitOpcode(   INST_END_CATCH,                            envPtr);
959    endTargetOffset = CurrentOffset(envPtr);
960    TclEmitInstInt4( INST_JUMP4, 0,                             envPtr);
961
962    /*
963     * Error handler "finally" clause, which force-terminates the iteration
964     * and rethrows the error.
965     */
966
967    ExceptionRangeTarget(envPtr, catchRange, catchOffset);
968    TclEmitOpcode(   INST_PUSH_RETURN_OPTIONS,                  envPtr);
969    TclEmitOpcode(   INST_PUSH_RESULT,                          envPtr);
970    TclEmitInstInt4( INST_DICT_DONE, infoIndex,                 envPtr);
971    TclEmitOpcode(   INST_END_CATCH,                            envPtr);
972    TclEmitOpcode(   INST_RETURN_STK,                           envPtr);
973
974    /*
975     * Otherwise we're done (the jump after the DICT_FIRST points here) and we
976     * need to pop the bogus key/value pair (pushed to keep stack calculations
977     * easy!) Note that we skip the END_CATCH. [Bug 1382528]
978     */
979
980    envPtr->currStackDepth = savedStackDepth+2;
981    jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
982    TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
983            envPtr->codeStart + emptyTargetOffset);
984    TclEmitOpcode(   INST_POP,                                  envPtr);
985    TclEmitOpcode(   INST_POP,                                  envPtr);
986    TclEmitInstInt4( INST_DICT_DONE, infoIndex,                 envPtr);
987
988    /*
989     * Final stage of the command (normal case) is that we push an empty
990     * object. This is done last to promote peephole optimization when it's
991     * dropped immediately.
992     */
993
994    jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
995    TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
996            envPtr->codeStart + endTargetOffset);
997    PushLiteral(envPtr, "", 0);
998    return TCL_OK;
999}
1000
1001int
1002TclCompileDictUpdateCmd(
1003    Tcl_Interp *interp,         /* Used for looking up stuff. */
1004    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1005                                 * created by Tcl_ParseCommand. */
1006    Command *cmdPtr,            /* Points to defintion of command being
1007                                 * compiled. */
1008    CompileEnv *envPtr)         /* Holds resulting instructions. */
1009{
1010    Proc *procPtr = envPtr->procPtr;
1011    DefineLineInformation;      /* TIP #280 */
1012    const char *name;
1013    int i, nameChars, dictIndex, numVars, range, infoIndex;
1014    Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
1015    DictUpdateInfo *duiPtr;
1016    JumpFixup jumpFixup;
1017
1018    /*
1019     * There must be at least one argument after the command.
1020     */
1021
1022    if (parsePtr->numWords < 5 || procPtr == NULL) {
1023        return TCL_ERROR;
1024    }
1025
1026    /*
1027     * Parse the command. Expect the following:
1028     *   dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit>
1029     */
1030
1031    if ((parsePtr->numWords - 1) & 1) {
1032        return TCL_ERROR;
1033    }
1034    numVars = (parsePtr->numWords - 3) / 2;
1035
1036    /*
1037     * The dictionary variable must be a local scalar that is knowable at
1038     * compile time; anything else exceeds the complexity of the opcode. So
1039     * discover what the index is.
1040     */
1041
1042    dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
1043    if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1044        return TCL_ERROR;
1045    }
1046    name = dictVarTokenPtr[1].start;
1047    nameChars = dictVarTokenPtr[1].size;
1048    if (!TclIsLocalScalar(name, nameChars)) {
1049        return TCL_ERROR;
1050    }
1051    dictIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
1052
1053    /*
1054     * Assemble the instruction metadata. This is complex enough that it is
1055     * represented as auxData; it holds an ordered list of variable indices
1056     * that are to be used.
1057     */
1058
1059    duiPtr = (DictUpdateInfo *)
1060            ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
1061    duiPtr->length = numVars;
1062    keyTokenPtrs = (Tcl_Token **) TclStackAlloc(interp,
1063            sizeof(Tcl_Token *) * numVars);
1064    tokenPtr = TokenAfter(dictVarTokenPtr);
1065
1066    for (i=0 ; i<numVars ; i++) {
1067        /*
1068         * Put keys to one side for later compilation to bytecode.
1069         */
1070
1071        keyTokenPtrs[i] = tokenPtr;
1072
1073        /*
1074         * Variables first need to be checked for sanity.
1075         */
1076
1077        tokenPtr = TokenAfter(tokenPtr);
1078        if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1079            ckfree((char *) duiPtr);
1080            TclStackFree(interp, keyTokenPtrs);
1081            return TCL_ERROR;
1082        }
1083        name = tokenPtr[1].start;
1084        nameChars = tokenPtr[1].size;
1085        if (!TclIsLocalScalar(name, nameChars)) {
1086            ckfree((char *) duiPtr);
1087            TclStackFree(interp, keyTokenPtrs);
1088            return TCL_ERROR;
1089        }
1090
1091        /*
1092         * Stash the index in the auxiliary data.
1093         */
1094
1095        duiPtr->varIndices[i] =
1096                TclFindCompiledLocal(name, nameChars, 1, procPtr);
1097        tokenPtr = TokenAfter(tokenPtr);
1098    }
1099    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1100        ckfree((char *) duiPtr);
1101        TclStackFree(interp, keyTokenPtrs);
1102        return TCL_ERROR;
1103    }
1104    bodyTokenPtr = tokenPtr;
1105
1106    /*
1107     * The list of variables to bind is stored in auxiliary data so that it
1108     * can't be snagged by literal sharing and forced to shimmer dangerously.
1109     */
1110
1111    infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr);
1112
1113    for (i=0 ; i<numVars ; i++) {
1114        CompileWord(envPtr, keyTokenPtrs[i], interp, i);
1115    }
1116    TclEmitInstInt4( INST_LIST, numVars,                        envPtr);
1117    TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex,         envPtr);
1118    TclEmitInt4(     infoIndex,                                 envPtr);
1119
1120    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
1121    TclEmitInstInt4( INST_BEGIN_CATCH4, range,                  envPtr);
1122
1123    ExceptionRangeStarts(envPtr, range);
1124    CompileBody(envPtr, bodyTokenPtr, interp);
1125    ExceptionRangeEnds(envPtr, range);
1126
1127    /*
1128     * Normal termination code: the stack has the key list below the result of
1129     * the body evaluation: swap them and finish the update code.
1130     */
1131
1132    TclEmitOpcode(   INST_END_CATCH,                            envPtr);
1133    TclEmitInstInt4( INST_REVERSE, 2,                           envPtr);
1134    TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex,           envPtr);
1135    TclEmitInt4(     infoIndex,                                 envPtr);
1136
1137    /*
1138     * Jump around the exceptional termination code.
1139     */
1140
1141    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
1142
1143    /*
1144     * Termination code for non-ok returns: stash the result and return
1145     * options in the stack, bring up the key list, finish the update code,
1146     * and finally return with the catched return data
1147     */
1148
1149    ExceptionRangeTarget(envPtr, range, catchOffset);
1150    TclEmitOpcode(   INST_PUSH_RESULT,                          envPtr);
1151    TclEmitOpcode(   INST_PUSH_RETURN_OPTIONS,                  envPtr);
1152    TclEmitOpcode(   INST_END_CATCH,                            envPtr);
1153    TclEmitInstInt4( INST_REVERSE, 3,                           envPtr);
1154
1155    TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex,           envPtr);
1156    TclEmitInt4(     infoIndex,                                 envPtr);
1157    TclEmitOpcode(   INST_RETURN_STK,                           envPtr);
1158
1159    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
1160        Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
1161                CurrentOffset(envPtr) - jumpFixup.codeOffset);
1162    }
1163    TclStackFree(interp, keyTokenPtrs);
1164    return TCL_OK;
1165}
1166
1167int
1168TclCompileDictAppendCmd(
1169    Tcl_Interp *interp,         /* Used for looking up stuff. */
1170    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1171                                 * created by Tcl_ParseCommand. */
1172    Command *cmdPtr,            /* Points to defintion of command being
1173                                 * compiled. */
1174    CompileEnv *envPtr)         /* Holds resulting instructions. */
1175{
1176    Proc *procPtr = envPtr->procPtr;
1177    DefineLineInformation;      /* TIP #280 */
1178    Tcl_Token *tokenPtr;
1179    int i, dictVarIndex;
1180
1181    /*
1182     * There must be at least two argument after the command. And we impose an
1183     * (arbirary) safe limit; anyone exceeding it should stop worrying about
1184     * speed quite so much. ;-)
1185     */
1186
1187    if (parsePtr->numWords<4 || parsePtr->numWords>100 || procPtr==NULL) {
1188        return TCL_ERROR;
1189    }
1190
1191    /*
1192     * Get the index of the local variable that we will be working with.
1193     */
1194
1195    tokenPtr = TokenAfter(parsePtr->tokenPtr);
1196    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1197        return TCL_ERROR;
1198    } else {
1199        register const char *name = tokenPtr[1].start;
1200        register int nameChars = tokenPtr[1].size;
1201
1202        if (!TclIsLocalScalar(name, nameChars)) {
1203            return TCL_ERROR;
1204        }
1205        dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
1206    }
1207
1208    /*
1209     * Produce the string to concatenate onto the dictionary entry.
1210     */
1211
1212    tokenPtr = TokenAfter(tokenPtr);
1213    for (i=2 ; i<parsePtr->numWords ; i++) {
1214        CompileWord(envPtr, tokenPtr, interp, i);
1215        tokenPtr = TokenAfter(tokenPtr);
1216    }
1217    if (parsePtr->numWords > 4) {
1218        TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-2, envPtr);
1219    }
1220
1221    /*
1222     * Do the concatenation.
1223     */
1224
1225    TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr);
1226    return TCL_OK;
1227}
1228
1229int
1230TclCompileDictLappendCmd(
1231    Tcl_Interp *interp,         /* Used for looking up stuff. */
1232    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1233                                 * created by Tcl_ParseCommand. */
1234    Command *cmdPtr,            /* Points to defintion of command being
1235                                 * compiled. */
1236    CompileEnv *envPtr)         /* Holds resulting instructions. */
1237{
1238    Proc *procPtr = envPtr->procPtr;
1239    DefineLineInformation;      /* TIP #280 */
1240    Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
1241    int dictVarIndex, nameChars;
1242    const char *name;
1243
1244    /*
1245     * There must be three arguments after the command.
1246     */
1247
1248    if (parsePtr->numWords != 4 || procPtr == NULL) {
1249        return TCL_ERROR;
1250    }
1251
1252    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
1253    keyTokenPtr = TokenAfter(varTokenPtr);
1254    valueTokenPtr = TokenAfter(keyTokenPtr);
1255    if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1256        return TCL_ERROR;
1257    }
1258    name = varTokenPtr[1].start;
1259    nameChars = varTokenPtr[1].size;
1260    if (!TclIsLocalScalar(name, nameChars)) {
1261        return TCL_ERROR;
1262    }
1263    dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
1264    CompileWord(envPtr, keyTokenPtr, interp, 3);
1265    CompileWord(envPtr, valueTokenPtr, interp, 4);
1266    TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
1267    return TCL_OK;
1268}
1269
1270/*
1271 *----------------------------------------------------------------------
1272 *
1273 * DupDictUpdateInfo, FreeDictUpdateInfo --
1274 *
1275 *      Functions to duplicate, release and print the aux data created for use
1276 *      with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions.
1277 *
1278 * Results:
1279 *      DupDictUpdateInfo: a copy of the auxiliary data
1280 *      FreeDictUpdateInfo: none
1281 *      PrintDictUpdateInfo: none
1282 *
1283 * Side effects:
1284 *      DupDictUpdateInfo: allocates memory
1285 *      FreeDictUpdateInfo: releases memory
1286 *      PrintDictUpdateInfo: none
1287 *
1288 *----------------------------------------------------------------------
1289 */
1290
1291static ClientData
1292DupDictUpdateInfo(
1293    ClientData clientData)
1294{
1295    DictUpdateInfo *dui1Ptr, *dui2Ptr;
1296    unsigned len;
1297
1298    dui1Ptr = clientData;
1299    len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
1300    dui2Ptr = (DictUpdateInfo *) ckalloc(len);
1301    memcpy(dui2Ptr, dui1Ptr, len);
1302    return dui2Ptr;
1303}
1304
1305static void
1306FreeDictUpdateInfo(
1307    ClientData clientData)
1308{
1309    ckfree(clientData);
1310}
1311
1312static void
1313PrintDictUpdateInfo(
1314    ClientData clientData,
1315    Tcl_Obj *appendObj,
1316    ByteCode *codePtr,
1317    unsigned int pcOffset)
1318{
1319    DictUpdateInfo *duiPtr = clientData;
1320    int i;
1321
1322    for (i=0 ; i<duiPtr->length ; i++) {
1323        if (i) {
1324            Tcl_AppendToObj(appendObj, ", ", -1);
1325        }
1326        Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
1327    }
1328}
1329
1330/*
1331 *----------------------------------------------------------------------
1332 *
1333 * TclCompileExprCmd --
1334 *
1335 *      Procedure called to compile the "expr" command.
1336 *
1337 * Results:
1338 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1339 *      evaluation to runtime.
1340 *
1341 * Side effects:
1342 *      Instructions are added to envPtr to execute the "expr" command at
1343 *      runtime.
1344 *
1345 *----------------------------------------------------------------------
1346 */
1347
1348int
1349TclCompileExprCmd(
1350    Tcl_Interp *interp,         /* Used for error reporting. */
1351    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1352                                 * created by Tcl_ParseCommand. */
1353    Command *cmdPtr,            /* Points to defintion of command being
1354                                 * compiled. */
1355    CompileEnv *envPtr)         /* Holds resulting instructions. */
1356{
1357    Tcl_Token *firstWordPtr;
1358
1359    if (parsePtr->numWords == 1) {
1360        return TCL_ERROR;
1361    }
1362
1363    /*
1364     * TIP #280: Use the per-word line information of the current command.
1365     */
1366
1367    envPtr->line = envPtr->extCmdMapPtr->loc[
1368            envPtr->extCmdMapPtr->nuloc-1].line[1];
1369
1370    firstWordPtr = TokenAfter(parsePtr->tokenPtr);
1371    TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr);
1372    return TCL_OK;
1373}
1374
1375/*
1376 *----------------------------------------------------------------------
1377 *
1378 * TclCompileForCmd --
1379 *
1380 *      Procedure called to compile the "for" command.
1381 *
1382 * Results:
1383 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1384 *      evaluation to runtime.
1385 *
1386 * Side effects:
1387 *      Instructions are added to envPtr to execute the "for" command at
1388 *      runtime.
1389 *
1390 *----------------------------------------------------------------------
1391 */
1392
1393int
1394TclCompileForCmd(
1395    Tcl_Interp *interp,         /* Used for error reporting. */
1396    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1397                                 * created by Tcl_ParseCommand. */
1398    Command *cmdPtr,            /* Points to defintion of command being
1399                                 * compiled. */
1400    CompileEnv *envPtr)         /* Holds resulting instructions. */
1401{
1402    Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
1403    JumpFixup jumpEvalCondFixup;
1404    int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
1405    int bodyRange, nextRange;
1406    int savedStackDepth = envPtr->currStackDepth;
1407    DefineLineInformation;      /* TIP #280 */
1408
1409    if (parsePtr->numWords != 5) {
1410        return TCL_ERROR;
1411    }
1412
1413    /*
1414     * If the test expression requires substitutions, don't compile the for
1415     * command inline. E.g., the expression might cause the loop to never
1416     * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
1417     */
1418
1419    startTokenPtr = TokenAfter(parsePtr->tokenPtr);
1420    testTokenPtr = TokenAfter(startTokenPtr);
1421    if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1422        return TCL_ERROR;
1423    }
1424
1425    /*
1426     * Bail out also if the body or the next expression require substitutions
1427     * in order to insure correct behaviour [Bug 219166]
1428     */
1429
1430    nextTokenPtr = TokenAfter(testTokenPtr);
1431    bodyTokenPtr = TokenAfter(nextTokenPtr);
1432    if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
1433            || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
1434        return TCL_ERROR;
1435    }
1436
1437    /*
1438     * Create ExceptionRange records for the body and the "next" command. The
1439     * "next" command's ExceptionRange supports break but not continue (and
1440     * has a -1 continueOffset).
1441     */
1442
1443    bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
1444    nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
1445
1446    /*
1447     * Inline compile the initial command.
1448     */
1449
1450    envPtr->line = mapPtr->loc[eclIndex].line[1];
1451    CompileBody(envPtr, startTokenPtr, interp);
1452    TclEmitOpcode(INST_POP, envPtr);
1453
1454    /*
1455     * Jump to the evaluation of the condition. This code uses the "loop
1456     * rotation" optimisation (which eliminates one branch from the loop).
1457     * "for start cond next body" produces then:
1458     *       start
1459     *       goto A
1460     *    B: body                : bodyCodeOffset
1461     *       next                : nextCodeOffset, continueOffset
1462     *    A: cond -> result      : testCodeOffset
1463     *       if (result) goto B
1464     */
1465
1466    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
1467
1468    /*
1469     * Compile the loop body.
1470     */
1471
1472    bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
1473    envPtr->line = mapPtr->loc[eclIndex].line[4];
1474    CompileBody(envPtr, bodyTokenPtr, interp);
1475    ExceptionRangeEnds(envPtr, bodyRange);
1476    envPtr->currStackDepth = savedStackDepth + 1;
1477    TclEmitOpcode(INST_POP, envPtr);
1478
1479    /*
1480     * Compile the "next" subcommand.
1481     */
1482
1483    envPtr->currStackDepth = savedStackDepth;
1484    nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
1485    envPtr->line = mapPtr->loc[eclIndex].line[3];
1486    CompileBody(envPtr, nextTokenPtr, interp);
1487    ExceptionRangeEnds(envPtr, nextRange);
1488    envPtr->currStackDepth = savedStackDepth + 1;
1489    TclEmitOpcode(INST_POP, envPtr);
1490    envPtr->currStackDepth = savedStackDepth;
1491
1492    /*
1493     * Compile the test expression then emit the conditional jump that
1494     * terminates the for.
1495     */
1496
1497    testCodeOffset = CurrentOffset(envPtr);
1498
1499    jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
1500    if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
1501        bodyCodeOffset += 3;
1502        nextCodeOffset += 3;
1503        testCodeOffset += 3;
1504    }
1505
1506    envPtr->line = mapPtr->loc[eclIndex].line[2];
1507    envPtr->currStackDepth = savedStackDepth;
1508    TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
1509    envPtr->currStackDepth = savedStackDepth + 1;
1510
1511    jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
1512    if (jumpDist > 127) {
1513        TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
1514    } else {
1515        TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
1516    }
1517
1518    /*
1519     * Fix the starting points of the exception ranges (may have moved due to
1520     * jump type modification) and set where the exceptions target.
1521     */
1522
1523    envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
1524    envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;
1525
1526    envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
1527
1528    ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
1529    ExceptionRangeTarget(envPtr, nextRange, breakOffset);
1530
1531    /*
1532     * The for command's result is an empty string.
1533     */
1534
1535    envPtr->currStackDepth = savedStackDepth;
1536    PushLiteral(envPtr, "", 0);
1537
1538    return TCL_OK;
1539}
1540
1541/*
1542 *----------------------------------------------------------------------
1543 *
1544 * TclCompileForeachCmd --
1545 *
1546 *      Procedure called to compile the "foreach" command.
1547 *
1548 * Results:
1549 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1550 *      evaluation to runtime.
1551 *
1552 * Side effects:
1553 *      Instructions are added to envPtr to execute the "foreach" command at
1554 *      runtime.
1555 *
1556 *----------------------------------------------------------------------
1557 */
1558
1559int
1560TclCompileForeachCmd(
1561    Tcl_Interp *interp,         /* Used for error reporting. */
1562    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1563                                 * created by Tcl_ParseCommand. */
1564    Command *cmdPtr,            /* Points to defintion of command being
1565                                 * compiled. */
1566    CompileEnv *envPtr)         /* Holds resulting instructions. */
1567{
1568    Proc *procPtr = envPtr->procPtr;
1569    ForeachInfo *infoPtr;       /* Points to the structure describing this
1570                                 * foreach command. Stored in a AuxData
1571                                 * record in the ByteCode. */
1572    int firstValueTemp;         /* Index of the first temp var in the frame
1573                                 * used to point to a value list. */
1574    int loopCtTemp;             /* Index of temp var holding the loop's
1575                                 * iteration count. */
1576    Tcl_Token *tokenPtr, *bodyTokenPtr;
1577    unsigned char *jumpPc;
1578    JumpFixup jumpFalseFixup;
1579    int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex;
1580    int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
1581    int savedStackDepth = envPtr->currStackDepth;
1582    DefineLineInformation;      /* TIP #280 */
1583
1584    /*
1585     * We parse the variable list argument words and create two arrays:
1586     *    varcList[i] is number of variables in i-th var list.
1587     *    varvList[i] points to array of var names in i-th var list.
1588     */
1589
1590    int *varcList;
1591    const char ***varvList;
1592
1593    /*
1594     * If the foreach command isn't in a procedure, don't compile it inline:
1595     * the payoff is too small.
1596     */
1597
1598    if (procPtr == NULL) {
1599        return TCL_ERROR;
1600    }
1601
1602    numWords = parsePtr->numWords;
1603    if ((numWords < 4) || (numWords%2 != 0)) {
1604        return TCL_ERROR;
1605    }
1606
1607    /*
1608     * Bail out if the body requires substitutions in order to insure correct
1609     * behaviour. [Bug 219166]
1610     */
1611
1612    for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) {
1613        tokenPtr = TokenAfter(tokenPtr);
1614    }
1615    bodyTokenPtr = tokenPtr;
1616    if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1617        return TCL_ERROR;
1618    }
1619
1620    bodyIndex = i-1;
1621
1622    /*
1623     * Allocate storage for the varcList and varvList arrays if necessary.
1624     */
1625
1626    numLists = (numWords - 2)/2;
1627    varcList = (int *) TclStackAlloc(interp, numLists * sizeof(int));
1628    memset(varcList, 0, numLists * sizeof(int));
1629    varvList = (const char ***) TclStackAlloc(interp,
1630            numLists * sizeof(const char **));
1631    memset((char*) varvList, 0, numLists * sizeof(const char **));
1632
1633    /*
1634     * Break up each var list and set the varcList and varvList arrays. Don't
1635     * compile the foreach inline if any var name needs substitutions or isn't
1636     * a scalar, or if any var list needs substitutions.
1637     */
1638
1639    loopIndex = 0;
1640    for (i = 0, tokenPtr = parsePtr->tokenPtr;
1641            i < numWords-1;
1642            i++, tokenPtr = TokenAfter(tokenPtr)) {
1643        Tcl_DString varList;
1644
1645        if (i%2 != 1) {
1646            continue;
1647        }
1648        if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1649            code = TCL_ERROR;
1650            goto done;
1651        }
1652
1653        /*
1654         * Lots of copying going on here. Need a ListObj wizard to show a
1655         * better way.
1656         */
1657
1658        Tcl_DStringInit(&varList);
1659        Tcl_DStringAppend(&varList, tokenPtr[1].start, tokenPtr[1].size);
1660        code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
1661                &varcList[loopIndex], &varvList[loopIndex]);
1662        Tcl_DStringFree(&varList);
1663        if (code != TCL_OK) {
1664            code = TCL_ERROR;
1665            goto done;
1666        }
1667        numVars = varcList[loopIndex];
1668
1669        /*
1670         * If the variable list is empty, we can enter an infinite loop when
1671         * the interpreted version would not. Take care to ensure this does
1672         * not happen. [Bug 1671138]
1673         */
1674
1675        if (numVars == 0) {
1676            code = TCL_ERROR;
1677            goto done;
1678        }
1679
1680        for (j = 0;  j < numVars;  j++) {
1681            const char *varName = varvList[loopIndex][j];
1682
1683            if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
1684                code = TCL_ERROR;
1685                goto done;
1686            }
1687        }
1688        loopIndex++;
1689    }
1690
1691    /*
1692     * We will compile the foreach command. Reserve (numLists + 1) temporary
1693     * variables:
1694     *    - numLists temps to hold each value list
1695     *    - 1 temp for the loop counter (index of next element in each list)
1696     *
1697     * At this time we don't try to reuse temporaries; if there are two
1698     * nonoverlapping foreach loops, they don't share any temps.
1699     */
1700
1701    code = TCL_OK;
1702    firstValueTemp = -1;
1703    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
1704        tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
1705                /*create*/ 1, procPtr);
1706        if (loopIndex == 0) {
1707            firstValueTemp = tempVar;
1708        }
1709    }
1710    loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
1711            /*create*/ 1, procPtr);
1712
1713    /*
1714     * Create and initialize the ForeachInfo and ForeachVarList data
1715     * structures describing this command. Then create a AuxData record
1716     * pointing to the ForeachInfo structure.
1717     */
1718
1719    infoPtr = (ForeachInfo *) ckalloc((unsigned)
1720            sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
1721    infoPtr->numLists = numLists;
1722    infoPtr->firstValueTemp = firstValueTemp;
1723    infoPtr->loopCtTemp = loopCtTemp;
1724    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
1725        ForeachVarList *varListPtr;
1726        numVars = varcList[loopIndex];
1727        varListPtr = (ForeachVarList *) ckalloc((unsigned)
1728                sizeof(ForeachVarList) + numVars*sizeof(int));
1729        varListPtr->numVars = numVars;
1730        for (j = 0;  j < numVars;  j++) {
1731            const char *varName = varvList[loopIndex][j];
1732            int nameChars = strlen(varName);
1733
1734            varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
1735                    nameChars, /*create*/ 1, procPtr);
1736        }
1737        infoPtr->varLists[loopIndex] = varListPtr;
1738    }
1739    infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
1740
1741    /*
1742     * Create an exception record to handle [break] and [continue].
1743     */
1744
1745    range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
1746
1747    /*
1748     * Evaluate then store each value list in the associated temporary.
1749     */
1750
1751    loopIndex = 0;
1752    for (i = 0, tokenPtr = parsePtr->tokenPtr;
1753            i < numWords-1;
1754            i++, tokenPtr = TokenAfter(tokenPtr)) {
1755        if ((i%2 == 0) && (i > 0)) {
1756            envPtr->line = mapPtr->loc[eclIndex].line[i];
1757            CompileTokens(envPtr, tokenPtr, interp);
1758            tempVar = (firstValueTemp + loopIndex);
1759            if (tempVar <= 255) {
1760                TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
1761            } else {
1762                TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
1763            }
1764            TclEmitOpcode(INST_POP, envPtr);
1765            loopIndex++;
1766        }
1767    }
1768
1769    /*
1770     * Initialize the temporary var that holds the count of loop iterations.
1771     */
1772
1773    TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
1774
1775    /*
1776     * Top of loop code: assign each loop variable and check whether
1777     * to terminate the loop.
1778     */
1779
1780    ExceptionRangeTarget(envPtr, range, continueOffset);
1781    TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
1782    TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
1783
1784    /*
1785     * Inline compile the loop body.
1786     */
1787
1788    envPtr->line = mapPtr->loc[eclIndex].line[bodyIndex];
1789    ExceptionRangeStarts(envPtr, range);
1790    CompileBody(envPtr, bodyTokenPtr, interp);
1791    ExceptionRangeEnds(envPtr, range);
1792    envPtr->currStackDepth = savedStackDepth + 1;
1793    TclEmitOpcode(INST_POP, envPtr);
1794
1795    /*
1796     * Jump back to the test at the top of the loop. Generate a 4 byte jump if
1797     * the distance to the test is > 120 bytes. This is conservative and
1798     * ensures that we won't have to replace this jump if we later need to
1799     * replace the ifFalse jump with a 4 byte jump.
1800     */
1801
1802    jumpBackOffset = CurrentOffset(envPtr);
1803    jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset;
1804    if (jumpBackDist > 120) {
1805        TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
1806    } else {
1807        TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
1808    }
1809
1810    /*
1811     * Fix the target of the jump after the foreach_step test.
1812     */
1813
1814    if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) {
1815        /*
1816         * Update the loop body's starting PC offset since it moved down.
1817         */
1818
1819        envPtr->exceptArrayPtr[range].codeOffset += 3;
1820
1821        /*
1822         * Update the jump back to the test at the top of the loop since it
1823         * also moved down 3 bytes.
1824         */
1825
1826        jumpBackOffset += 3;
1827        jumpPc = (envPtr->codeStart + jumpBackOffset);
1828        jumpBackDist += 3;
1829        if (jumpBackDist > 120) {
1830            TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
1831        } else {
1832            TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
1833        }
1834    }
1835
1836    /*
1837     * Set the loop's break target.
1838     */
1839
1840    ExceptionRangeTarget(envPtr, range, breakOffset);
1841
1842    /*
1843     * The foreach command's result is an empty string.
1844     */
1845
1846    envPtr->currStackDepth = savedStackDepth;
1847    PushLiteral(envPtr, "", 0);
1848    envPtr->currStackDepth = savedStackDepth + 1;
1849
1850  done:
1851    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
1852        if (varvList[loopIndex] != NULL) {
1853            ckfree((char *) varvList[loopIndex]);
1854        }
1855    }
1856    TclStackFree(interp, (void *)varvList);
1857    TclStackFree(interp, varcList);
1858    return code;
1859}
1860
1861/*
1862 *----------------------------------------------------------------------
1863 *
1864 * DupForeachInfo --
1865 *
1866 *      This procedure duplicates a ForeachInfo structure created as auxiliary
1867 *      data during the compilation of a foreach command.
1868 *
1869 * Results:
1870 *      A pointer to a newly allocated copy of the existing ForeachInfo
1871 *      structure is returned.
1872 *
1873 * Side effects:
1874 *      Storage for the copied ForeachInfo record is allocated. If the
1875 *      original ForeachInfo structure pointed to any ForeachVarList records,
1876 *      these structures are also copied and pointers to them are stored in
1877 *      the new ForeachInfo record.
1878 *
1879 *----------------------------------------------------------------------
1880 */
1881
1882static ClientData
1883DupForeachInfo(
1884    ClientData clientData)      /* The foreach command's compilation auxiliary
1885                                 * data to duplicate. */
1886{
1887    register ForeachInfo *srcPtr = clientData;
1888    ForeachInfo *dupPtr;
1889    register ForeachVarList *srcListPtr, *dupListPtr;
1890    int numVars, i, j, numLists = srcPtr->numLists;
1891
1892    dupPtr = (ForeachInfo *) ckalloc((unsigned)
1893            sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
1894    dupPtr->numLists = numLists;
1895    dupPtr->firstValueTemp = srcPtr->firstValueTemp;
1896    dupPtr->loopCtTemp = srcPtr->loopCtTemp;
1897
1898    for (i = 0;  i < numLists;  i++) {
1899        srcListPtr = srcPtr->varLists[i];
1900        numVars = srcListPtr->numVars;
1901        dupListPtr = (ForeachVarList *) ckalloc((unsigned)
1902                sizeof(ForeachVarList) + numVars*sizeof(int));
1903        dupListPtr->numVars = numVars;
1904        for (j = 0;  j < numVars;  j++) {
1905            dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
1906        }
1907        dupPtr->varLists[i] = dupListPtr;
1908    }
1909    return dupPtr;
1910}
1911
1912/*
1913 *----------------------------------------------------------------------
1914 *
1915 * FreeForeachInfo --
1916 *
1917 *      Procedure to free a ForeachInfo structure created as auxiliary data
1918 *      during the compilation of a foreach command.
1919 *
1920 * Results:
1921 *      None.
1922 *
1923 * Side effects:
1924 *      Storage for the ForeachInfo structure pointed to by the ClientData
1925 *      argument is freed as is any ForeachVarList record pointed to by the
1926 *      ForeachInfo structure.
1927 *
1928 *----------------------------------------------------------------------
1929 */
1930
1931static void
1932FreeForeachInfo(
1933    ClientData clientData)      /* The foreach command's compilation auxiliary
1934                                 * data to free. */
1935{
1936    register ForeachInfo *infoPtr = clientData;
1937    register ForeachVarList *listPtr;
1938    int numLists = infoPtr->numLists;
1939    register int i;
1940
1941    for (i = 0;  i < numLists;  i++) {
1942        listPtr = infoPtr->varLists[i];
1943        ckfree((char *) listPtr);
1944    }
1945    ckfree((char *) infoPtr);
1946}
1947
1948/*
1949 *----------------------------------------------------------------------
1950 *
1951 * PrintForeachInfo --
1952 *
1953 *      Function to write a human-readable representation of a ForeachInfo
1954 *      structure to stdout for debugging.
1955 *
1956 * Results:
1957 *      None.
1958 *
1959 * Side effects:
1960 *      None.
1961 *
1962 *----------------------------------------------------------------------
1963 */
1964
1965static void
1966PrintForeachInfo(
1967    ClientData clientData,
1968    Tcl_Obj *appendObj,
1969    ByteCode *codePtr,
1970    unsigned int pcOffset)
1971{
1972    register ForeachInfo *infoPtr = clientData;
1973    register ForeachVarList *varsPtr;
1974    int i, j;
1975
1976    Tcl_AppendToObj(appendObj, "data=[", -1);
1977
1978    for (i=0 ; i<infoPtr->numLists ; i++) {
1979        if (i) {
1980            Tcl_AppendToObj(appendObj, ", ", -1);
1981        }
1982        Tcl_AppendPrintfToObj(appendObj, "%%v%u",
1983                (unsigned) (infoPtr->firstValueTemp + i));
1984    }
1985    Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u",
1986            (unsigned) infoPtr->loopCtTemp);
1987    for (i=0 ; i<infoPtr->numLists ; i++) {
1988        if (i) {
1989            Tcl_AppendToObj(appendObj, ",", -1);
1990        }
1991        Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[",
1992                (unsigned) (infoPtr->firstValueTemp + i));
1993        varsPtr = infoPtr->varLists[i];
1994        for (j=0 ; j<varsPtr->numVars ; j++) {
1995            if (j) {
1996                Tcl_AppendToObj(appendObj, ", ", -1);
1997            }
1998            Tcl_AppendPrintfToObj(appendObj, "%%v%u",
1999                    (unsigned) varsPtr->varIndexes[j]);
2000        }
2001        Tcl_AppendToObj(appendObj, "]", -1);
2002    }
2003}
2004
2005/*
2006 *----------------------------------------------------------------------
2007 *
2008 * TclCompileIfCmd --
2009 *
2010 *      Procedure called to compile the "if" command.
2011 *
2012 * Results:
2013 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2014 *      evaluation to runtime.
2015 *
2016 * Side effects:
2017 *      Instructions are added to envPtr to execute the "if" command at
2018 *      runtime.
2019 *
2020 *----------------------------------------------------------------------
2021 */
2022
2023int
2024TclCompileIfCmd(
2025    Tcl_Interp *interp,         /* Used for error reporting. */
2026    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2027                                 * created by Tcl_ParseCommand. */
2028    Command *cmdPtr,            /* Points to defintion of command being
2029                                 * compiled. */
2030    CompileEnv *envPtr)         /* Holds resulting instructions. */
2031{
2032    JumpFixupArray jumpFalseFixupArray;
2033                                /* Used to fix the ifFalse jump after each
2034                                 * test when its target PC is determined. */
2035    JumpFixupArray jumpEndFixupArray;
2036                                /* Used to fix the jump after each "then" body
2037                                 * to the end of the "if" when that PC is
2038                                 * determined. */
2039    Tcl_Token *tokenPtr, *testTokenPtr;
2040    int jumpIndex = 0;          /* Avoid compiler warning. */
2041    int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
2042    const char *word;
2043    int savedStackDepth = envPtr->currStackDepth;
2044                                /* Saved stack depth at the start of the first
2045                                 * test; the envPtr current depth is restored
2046                                 * to this value at the start of each test. */
2047    int realCond = 1;           /* Set to 0 for static conditions:
2048                                 * "if 0 {..}" */
2049    int boolVal;                /* Value of static condition. */
2050    int compileScripts = 1;
2051    DefineLineInformation;      /* TIP #280 */
2052
2053    /*
2054     * Only compile the "if" command if all arguments are simple words, in
2055     * order to insure correct substitution [Bug 219166]
2056     */
2057
2058    tokenPtr = parsePtr->tokenPtr;
2059    wordIdx = 0;
2060    numWords = parsePtr->numWords;
2061
2062    for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
2063        if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
2064            return TCL_ERROR;
2065        }
2066        tokenPtr = TokenAfter(tokenPtr);
2067    }
2068
2069    TclInitJumpFixupArray(&jumpFalseFixupArray);
2070    TclInitJumpFixupArray(&jumpEndFixupArray);
2071    code = TCL_OK;
2072
2073    /*
2074     * Each iteration of this loop compiles one "if expr ?then? body" or
2075     * "elseif expr ?then? body" clause.
2076     */
2077
2078    tokenPtr = parsePtr->tokenPtr;
2079    wordIdx = 0;
2080    while (wordIdx < numWords) {
2081        /*
2082         * Stop looping if the token isn't "if" or "elseif".
2083         */
2084
2085        word = tokenPtr[1].start;
2086        numBytes = tokenPtr[1].size;
2087        if ((tokenPtr == parsePtr->tokenPtr)
2088                || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
2089            tokenPtr = TokenAfter(tokenPtr);
2090            wordIdx++;
2091        } else {
2092            break;
2093        }
2094        if (wordIdx >= numWords) {
2095            code = TCL_ERROR;
2096            goto done;
2097        }
2098
2099        /*
2100         * Compile the test expression then emit the conditional jump around
2101         * the "then" part.
2102         */
2103
2104        envPtr->currStackDepth = savedStackDepth;
2105        testTokenPtr = tokenPtr;
2106
2107        if (realCond) {
2108            /*
2109             * Find out if the condition is a constant.
2110             */
2111
2112            Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
2113                    testTokenPtr[1].size);
2114            Tcl_IncrRefCount(boolObj);
2115            code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
2116            TclDecrRefCount(boolObj);
2117            if (code == TCL_OK) {
2118                /*
2119                 * A static condition.
2120                 */
2121
2122                realCond = 0;
2123                if (!boolVal) {
2124                    compileScripts = 0;
2125                }
2126            } else {
2127                envPtr->line = mapPtr->loc[eclIndex].line[wordIdx];
2128                Tcl_ResetResult(interp);
2129                TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
2130                if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
2131                    TclExpandJumpFixupArray(&jumpFalseFixupArray);
2132                }
2133                jumpIndex = jumpFalseFixupArray.next;
2134                jumpFalseFixupArray.next++;
2135                TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
2136                        jumpFalseFixupArray.fixup+jumpIndex);
2137            }
2138            code = TCL_OK;
2139        }
2140
2141        /*
2142         * Skip over the optional "then" before the then clause.
2143         */
2144
2145        tokenPtr = TokenAfter(testTokenPtr);
2146        wordIdx++;
2147        if (wordIdx >= numWords) {
2148            code = TCL_ERROR;
2149            goto done;
2150        }
2151        if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
2152            word = tokenPtr[1].start;
2153            numBytes = tokenPtr[1].size;
2154            if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
2155                tokenPtr = TokenAfter(tokenPtr);
2156                wordIdx++;
2157                if (wordIdx >= numWords) {
2158                    code = TCL_ERROR;
2159                    goto done;
2160                }
2161            }
2162        }
2163
2164        /*
2165         * Compile the "then" command body.
2166         */
2167
2168        if (compileScripts) {
2169            envPtr->line = mapPtr->loc[eclIndex].line[wordIdx];
2170            envPtr->currStackDepth = savedStackDepth;
2171            CompileBody(envPtr, tokenPtr, interp);
2172        }
2173
2174        if (realCond) {
2175            /*
2176             * Jump to the end of the "if" command. Both jumpFalseFixupArray
2177             * and jumpEndFixupArray are indexed by "jumpIndex".
2178             */
2179
2180            if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
2181                TclExpandJumpFixupArray(&jumpEndFixupArray);
2182            }
2183            jumpEndFixupArray.next++;
2184            TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
2185                    jumpEndFixupArray.fixup+jumpIndex);
2186
2187            /*
2188             * Fix the target of the jumpFalse after the test. Generate a 4
2189             * byte jump if the distance is > 120 bytes. This is conservative,
2190             * and ensures that we won't have to replace this jump if we later
2191             * also need to replace the proceeding jump to the end of the "if"
2192             * with a 4 byte jump.
2193             */
2194
2195            if (TclFixupForwardJumpToHere(envPtr,
2196                    jumpFalseFixupArray.fixup+jumpIndex, 120)) {
2197                /*
2198                 * Adjust the code offset for the proceeding jump to the end
2199                 * of the "if" command.
2200                 */
2201
2202                jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
2203            }
2204        } else if (boolVal) {
2205            /*
2206             * We were processing an "if 1 {...}"; stop compiling scripts.
2207             */
2208
2209            compileScripts = 0;
2210        } else {
2211            /*
2212             * We were processing an "if 0 {...}"; reset so that the rest
2213             * (elseif, else) is compiled correctly.
2214             */
2215
2216            realCond = 1;
2217            compileScripts = 1;
2218        }
2219
2220        tokenPtr = TokenAfter(tokenPtr);
2221        wordIdx++;
2222    }
2223
2224    /*
2225     * Restore the current stack depth in the environment; the "else" clause
2226     * (or its default) will add 1 to this.
2227     */
2228
2229    envPtr->currStackDepth = savedStackDepth;
2230
2231    /*
2232     * Check for the optional else clause. Do not compile anything if this was
2233     * an "if 1 {...}" case.
2234     */
2235
2236    if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
2237        /*
2238         * There is an else clause. Skip over the optional "else" word.
2239         */
2240
2241        word = tokenPtr[1].start;
2242        numBytes = tokenPtr[1].size;
2243        if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
2244            tokenPtr = TokenAfter(tokenPtr);
2245            wordIdx++;
2246            if (wordIdx >= numWords) {
2247                code = TCL_ERROR;
2248                goto done;
2249            }
2250        }
2251
2252        if (compileScripts) {
2253            /*
2254             * Compile the else command body.
2255             */
2256
2257            envPtr->line = mapPtr->loc[eclIndex].line[wordIdx];
2258            CompileBody(envPtr, tokenPtr, interp);
2259        }
2260
2261        /*
2262         * Make sure there are no words after the else clause.
2263         */
2264
2265        wordIdx++;
2266        if (wordIdx < numWords) {
2267            code = TCL_ERROR;
2268            goto done;
2269        }
2270    } else {
2271        /*
2272         * No else clause: the "if" command's result is an empty string.
2273         */
2274
2275        if (compileScripts) {
2276            PushLiteral(envPtr, "", 0);
2277        }
2278    }
2279
2280    /*
2281     * Fix the unconditional jumps to the end of the "if" command.
2282     */
2283
2284    for (j = jumpEndFixupArray.next;  j > 0;  j--) {
2285        jumpIndex = (j - 1);    /* i.e. process the closest jump first. */
2286        if (TclFixupForwardJumpToHere(envPtr,
2287                jumpEndFixupArray.fixup+jumpIndex, 127)) {
2288            /*
2289             * Adjust the immediately preceeding "ifFalse" jump. We moved it's
2290             * target (just after this jump) down three bytes.
2291             */
2292
2293            unsigned char *ifFalsePc = envPtr->codeStart
2294                    + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
2295            unsigned char opCode = *ifFalsePc;
2296
2297            if (opCode == INST_JUMP_FALSE1) {
2298                jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
2299                jumpFalseDist += 3;
2300                TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
2301            } else if (opCode == INST_JUMP_FALSE4) {
2302                jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
2303                jumpFalseDist += 3;
2304                TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
2305            } else {
2306                Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
2307            }
2308        }
2309    }
2310
2311    /*
2312     * Free the jumpFixupArray array if malloc'ed storage was used.
2313     */
2314
2315  done:
2316    envPtr->currStackDepth = savedStackDepth + 1;
2317    TclFreeJumpFixupArray(&jumpFalseFixupArray);
2318    TclFreeJumpFixupArray(&jumpEndFixupArray);
2319    return code;
2320}
2321
2322/*
2323 *----------------------------------------------------------------------
2324 *
2325 * TclCompileIncrCmd --
2326 *
2327 *      Procedure called to compile the "incr" command.
2328 *
2329 * Results:
2330 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2331 *      evaluation to runtime.
2332 *
2333 * Side effects:
2334 *      Instructions are added to envPtr to execute the "incr" command at
2335 *      runtime.
2336 *
2337 *----------------------------------------------------------------------
2338 */
2339
2340int
2341TclCompileIncrCmd(
2342    Tcl_Interp *interp,         /* Used for error reporting. */
2343    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2344                                 * created by Tcl_ParseCommand. */
2345    Command *cmdPtr,            /* Points to defintion of command being
2346                                 * compiled. */
2347    CompileEnv *envPtr)         /* Holds resulting instructions. */
2348{
2349    Tcl_Token *varTokenPtr, *incrTokenPtr;
2350    int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
2351    DefineLineInformation;      /* TIP #280 */
2352
2353    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
2354        return TCL_ERROR;
2355    }
2356
2357    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
2358
2359    PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR,
2360                &localIndex, &simpleVarName, &isScalar,
2361                mapPtr->loc[eclIndex].line[1]);
2362
2363    /*
2364     * If an increment is given, push it, but see first if it's a small
2365     * integer.
2366     */
2367
2368    haveImmValue = 0;
2369    immValue = 1;
2370    if (parsePtr->numWords == 3) {
2371        incrTokenPtr = TokenAfter(varTokenPtr);
2372        if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
2373            const char *word = incrTokenPtr[1].start;
2374            int numBytes = incrTokenPtr[1].size;
2375            int code;
2376            Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
2377            Tcl_IncrRefCount(intObj);
2378            code = TclGetIntFromObj(NULL, intObj, &immValue);
2379            TclDecrRefCount(intObj);
2380            if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
2381                haveImmValue = 1;
2382            }
2383            if (!haveImmValue) {
2384                PushLiteral(envPtr, word, numBytes);
2385            }
2386        } else {
2387            envPtr->line = mapPtr->loc[eclIndex].line[2];
2388            CompileTokens(envPtr, incrTokenPtr, interp);
2389        }
2390    } else {                    /* No incr amount given so use 1. */
2391        haveImmValue = 1;
2392    }
2393
2394    /*
2395     * Emit the instruction to increment the variable.
2396     */
2397
2398    if (simpleVarName) {
2399        if (isScalar) {
2400            if (localIndex >= 0) {
2401                if (haveImmValue) {
2402                    TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
2403                    TclEmitInt1(immValue, envPtr);
2404                } else {
2405                    TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
2406                }
2407            } else {
2408                if (haveImmValue) {
2409                    TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
2410                } else {
2411                    TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
2412                }
2413            }
2414        } else {
2415            if (localIndex >= 0) {
2416                if (haveImmValue) {
2417                    TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
2418                    TclEmitInt1(immValue, envPtr);
2419                } else {
2420                    TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
2421                }
2422            } else {
2423                if (haveImmValue) {
2424                    TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
2425                } else {
2426                    TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
2427                }
2428            }
2429        }
2430    } else {                    /* Non-simple variable name. */
2431        if (haveImmValue) {
2432            TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
2433        } else {
2434            TclEmitOpcode(INST_INCR_STK, envPtr);
2435        }
2436    }
2437
2438    return TCL_OK;
2439}
2440
2441/*
2442 *----------------------------------------------------------------------
2443 *
2444 * TclCompileLappendCmd --
2445 *
2446 *      Procedure called to compile the "lappend" command.
2447 *
2448 * Results:
2449 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2450 *      evaluation to runtime.
2451 *
2452 * Side effects:
2453 *      Instructions are added to envPtr to execute the "lappend" command at
2454 *      runtime.
2455 *
2456 *----------------------------------------------------------------------
2457 */
2458
2459int
2460TclCompileLappendCmd(
2461    Tcl_Interp *interp,         /* Used for error reporting. */
2462    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2463                                 * created by Tcl_ParseCommand. */
2464    Command *cmdPtr,            /* Points to defintion of command being
2465                                 * compiled. */
2466    CompileEnv *envPtr)         /* Holds resulting instructions. */
2467{
2468    Tcl_Token *varTokenPtr;
2469    int simpleVarName, isScalar, localIndex, numWords;
2470    DefineLineInformation;      /* TIP #280 */
2471
2472    /*
2473     * If we're not in a procedure, don't compile.
2474     */
2475
2476    if (envPtr->procPtr == NULL) {
2477        return TCL_ERROR;
2478    }
2479
2480    numWords = parsePtr->numWords;
2481    if (numWords == 1) {
2482        return TCL_ERROR;
2483    }
2484    if (numWords != 3) {
2485        /*
2486         * LAPPEND instructions currently only handle one value appends.
2487         */
2488
2489        return TCL_ERROR;
2490    }
2491
2492    /*
2493     * Decide if we can use a frame slot for the var/array name or if we
2494     * need to emit code to compute and push the name at runtime. We use a
2495     * frame slot (entry in the array of local vars) if we are compiling a
2496     * procedure body and if the name is simple text that does not include
2497     * namespace qualifiers.
2498     */
2499
2500    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
2501
2502    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
2503                &localIndex, &simpleVarName, &isScalar,
2504                mapPtr->loc[eclIndex].line[1]);
2505
2506    /*
2507     * If we are doing an assignment, push the new value. In the no values
2508     * case, create an empty object.
2509     */
2510
2511    if (numWords > 2) {
2512        Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
2513        CompileWord(envPtr, valueTokenPtr, interp, 2);
2514    }
2515
2516    /*
2517     * Emit instructions to set/get the variable.
2518     */
2519
2520    /*
2521     * The *_STK opcodes should be refactored to make better use of existing
2522     * LOAD/STORE instructions.
2523     */
2524
2525    if (simpleVarName) {
2526        if (isScalar) {
2527            if (localIndex < 0) {
2528                TclEmitOpcode(INST_LAPPEND_STK, envPtr);
2529            } else if (localIndex <= 255) {
2530                TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
2531            } else {
2532                TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
2533            }
2534        } else {
2535            if (localIndex < 0) {
2536                TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
2537            } else if (localIndex <= 255) {
2538                TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
2539            } else {
2540                TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
2541            }
2542        }
2543    } else {
2544        TclEmitOpcode(INST_LAPPEND_STK, envPtr);
2545    }
2546
2547    return TCL_OK;
2548}
2549
2550/*
2551 *----------------------------------------------------------------------
2552 *
2553 * TclCompileLassignCmd --
2554 *
2555 *      Procedure called to compile the "lassign" command.
2556 *
2557 * Results:
2558 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2559 *      evaluation to runtime.
2560 *
2561 * Side effects:
2562 *      Instructions are added to envPtr to execute the "lassign" command at
2563 *      runtime.
2564 *
2565 *----------------------------------------------------------------------
2566 */
2567
2568int
2569TclCompileLassignCmd(
2570    Tcl_Interp *interp,         /* Used for error reporting. */
2571    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2572                                 * created by Tcl_ParseCommand. */
2573    Command *cmdPtr,            /* Points to defintion of command being
2574                                 * compiled. */
2575    CompileEnv *envPtr)         /* Holds resulting instructions. */
2576{
2577    Tcl_Token *tokenPtr;
2578    int simpleVarName, isScalar, localIndex, numWords, idx;
2579    DefineLineInformation;      /* TIP #280 */
2580
2581    numWords = parsePtr->numWords;
2582
2583    /*
2584     * Check for command syntax error, but we'll punt that to runtime.
2585     */
2586
2587    if (numWords < 3) {
2588        return TCL_ERROR;
2589    }
2590
2591    /*
2592     * Generate code to push list being taken apart by [lassign].
2593     */
2594
2595    tokenPtr = TokenAfter(parsePtr->tokenPtr);
2596    CompileWord(envPtr, tokenPtr, interp, 1);
2597
2598    /*
2599     * Generate code to assign values from the list to variables.
2600     */
2601
2602    for (idx=0 ; idx<numWords-2 ; idx++) {
2603        tokenPtr = TokenAfter(tokenPtr);
2604
2605        /*
2606         * Generate the next variable name.
2607         */
2608
2609        PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
2610                &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[idx+2]);
2611
2612        /*
2613         * Emit instructions to get the idx'th item out of the list value on
2614         * the stack and assign it to the variable.
2615         */
2616
2617        if (simpleVarName) {
2618            if (isScalar) {
2619                if (localIndex >= 0) {
2620                    TclEmitOpcode(INST_DUP, envPtr);
2621                    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
2622                    if (localIndex <= 255) {
2623                        TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr);
2624                    } else {
2625                        TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr);
2626                    }
2627                } else {
2628                    TclEmitInstInt4(INST_OVER, 1, envPtr);
2629                    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
2630                    TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
2631                }
2632            } else {
2633                if (localIndex >= 0) {
2634                    TclEmitInstInt4(INST_OVER, 1, envPtr);
2635                    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
2636                    if (localIndex <= 255) {
2637                        TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
2638                    } else {
2639                        TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
2640                    }
2641                } else {
2642                    TclEmitInstInt4(INST_OVER, 2, envPtr);
2643                    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
2644                    TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
2645                }
2646            }
2647        } else {
2648            TclEmitInstInt4(INST_OVER, 1, envPtr);
2649            TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
2650            TclEmitOpcode(INST_STORE_STK, envPtr);
2651        }
2652        TclEmitOpcode(INST_POP, envPtr);
2653    }
2654
2655    /*
2656     * Generate code to leave the rest of the list on the stack.
2657     */
2658
2659    TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr);
2660    TclEmitInt4(-2, envPtr);    /* -2 == "end" */
2661
2662    return TCL_OK;
2663}
2664
2665/*
2666 *----------------------------------------------------------------------
2667 *
2668 * TclCompileLindexCmd --
2669 *
2670 *      Procedure called to compile the "lindex" command.
2671 *
2672 * Results:
2673 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2674 *      evaluation to runtime.
2675 *
2676 * Side effects:
2677 *      Instructions are added to envPtr to execute the "lindex" command at
2678 *      runtime.
2679 *
2680 *----------------------------------------------------------------------
2681 */
2682
2683int
2684TclCompileLindexCmd(
2685    Tcl_Interp *interp,         /* Used for error reporting. */
2686    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2687                                 * created by Tcl_ParseCommand. */
2688    Command *cmdPtr,            /* Points to defintion of command being
2689                                 * compiled. */
2690    CompileEnv *envPtr)         /* Holds resulting instructions. */
2691{
2692    Tcl_Token *idxTokenPtr, *valTokenPtr;
2693    int i, numWords = parsePtr->numWords;
2694    DefineLineInformation;      /* TIP #280 */
2695
2696    /*
2697     * Quit if too few args.
2698     */
2699
2700    if (numWords <= 1) {
2701        return TCL_ERROR;
2702    }
2703
2704    valTokenPtr = TokenAfter(parsePtr->tokenPtr);
2705    if (numWords != 3) {
2706        goto emitComplexLindex;
2707    }
2708
2709    idxTokenPtr = TokenAfter(valTokenPtr);
2710    if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
2711        Tcl_Obj *tmpObj;
2712        int idx, result;
2713
2714        tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
2715        result = TclGetIntFromObj(NULL, tmpObj, &idx);
2716        TclDecrRefCount(tmpObj);
2717
2718        if (result == TCL_OK && idx >= 0) {
2719            /*
2720             * All checks have been completed, and we have exactly this
2721             * construct:
2722             *   lindex <arbitraryValue> <posInt>
2723             * This is best compiled as a push of the arbitrary value followed
2724             * by an "immediate lindex" which is the most efficient variety.
2725             */
2726
2727            CompileWord(envPtr, valTokenPtr, interp, 1);
2728            TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
2729            return TCL_OK;
2730        }
2731
2732        /*
2733         * If the conversion failed or the value was negative, we just keep on
2734         * going with the more complex compilation.
2735         */
2736    }
2737
2738    /*
2739     * Push the operands onto the stack.
2740     */
2741
2742  emitComplexLindex:
2743    for (i=1 ; i<numWords ; i++) {
2744        CompileWord(envPtr, valTokenPtr, interp, i);
2745        valTokenPtr = TokenAfter(valTokenPtr);
2746    }
2747
2748    /*
2749     * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
2750     * multiple index args.
2751     */
2752
2753    if (numWords == 3) {
2754        TclEmitOpcode(INST_LIST_INDEX, envPtr);
2755    } else {
2756        TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
2757    }
2758
2759    return TCL_OK;
2760}
2761
2762/*
2763 *----------------------------------------------------------------------
2764 *
2765 * TclCompileListCmd --
2766 *
2767 *      Procedure called to compile the "list" command.
2768 *
2769 * Results:
2770 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2771 *      evaluation to runtime.
2772 *
2773 * Side effects:
2774 *      Instructions are added to envPtr to execute the "list" command at
2775 *      runtime.
2776 *
2777 *----------------------------------------------------------------------
2778 */
2779
2780int
2781TclCompileListCmd(
2782    Tcl_Interp *interp,         /* Used for error reporting. */
2783    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2784                                 * created by Tcl_ParseCommand. */
2785    Command *cmdPtr,            /* Points to defintion of command being
2786                                 * compiled. */
2787    CompileEnv *envPtr)         /* Holds resulting instructions. */
2788{
2789    DefineLineInformation;      /* TIP #280 */
2790
2791    /*
2792     * If we're not in a procedure, don't compile.
2793     */
2794
2795    if (envPtr->procPtr == NULL) {
2796        return TCL_ERROR;
2797    }
2798
2799    if (parsePtr->numWords == 1) {
2800        /*
2801         * [list] without arguments just pushes an empty object.
2802         */
2803
2804        PushLiteral(envPtr, "", 0);
2805    } else {
2806        /*
2807         * Push the all values onto the stack.
2808         */
2809
2810        Tcl_Token *valueTokenPtr;
2811        int i, numWords;
2812
2813        numWords = parsePtr->numWords;
2814
2815        valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
2816        for (i = 1; i < numWords; i++) {
2817            CompileWord(envPtr, valueTokenPtr, interp, i);
2818            valueTokenPtr = TokenAfter(valueTokenPtr);
2819        }
2820        TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
2821    }
2822
2823    return TCL_OK;
2824}
2825
2826/*
2827 *----------------------------------------------------------------------
2828 *
2829 * TclCompileLlengthCmd --
2830 *
2831 *      Procedure called to compile the "llength" command.
2832 *
2833 * Results:
2834 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2835 *      evaluation to runtime.
2836 *
2837 * Side effects:
2838 *      Instructions are added to envPtr to execute the "llength" command at
2839 *      runtime.
2840 *
2841 *----------------------------------------------------------------------
2842 */
2843
2844int
2845TclCompileLlengthCmd(
2846    Tcl_Interp *interp,         /* Used for error reporting. */
2847    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2848                                 * created by Tcl_ParseCommand. */
2849    Command *cmdPtr,            /* Points to defintion of command being
2850                                 * compiled. */
2851    CompileEnv *envPtr)         /* Holds resulting instructions. */
2852{
2853    Tcl_Token *varTokenPtr;
2854    DefineLineInformation;      /* TIP #280 */
2855
2856    if (parsePtr->numWords != 2) {
2857        return TCL_ERROR;
2858    }
2859    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
2860
2861    CompileWord(envPtr, varTokenPtr, interp, 1);
2862    TclEmitOpcode(INST_LIST_LENGTH, envPtr);
2863    return TCL_OK;
2864}
2865
2866/*
2867 *----------------------------------------------------------------------
2868 *
2869 * TclCompileLsetCmd --
2870 *
2871 *      Procedure called to compile the "lset" command.
2872 *
2873 * Results:
2874 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2875 *      evaluation to runtime.
2876 *
2877 * Side effects:
2878 *      Instructions are added to envPtr to execute the "lset" command at
2879 *      runtime.
2880 *
2881 * The general template for execution of the "lset" command is:
2882 *      (1) Instructions to push the variable name, unless the variable is
2883 *          local to the stack frame.
2884 *      (2) If the variable is an array element, instructions to push the
2885 *          array element name.
2886 *      (3) Instructions to push each of zero or more "index" arguments to the
2887 *          stack, followed with the "newValue" element.
2888 *      (4) Instructions to duplicate the variable name and/or array element
2889 *          name onto the top of the stack, if either was pushed at steps (1)
2890 *          and (2).
2891 *      (5) The appropriate INST_LOAD_* instruction to place the original
2892 *          value of the list variable at top of stack.
2893 *      (6) At this point, the stack contains:
2894 *              varName? arrayElementName? index1 index2 ... newValue oldList
2895 *          The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
2896 *          according as whether there is exactly one index element (LIST) or
2897 *          either zero or else two or more (FLAT). This instruction removes
2898 *          everything from the stack except for the two names and pushes the
2899 *          new value of the variable.
2900 *      (7) Finally, INST_STORE_* stores the new value in the variable and
2901 *          cleans up the stack.
2902 *
2903 *----------------------------------------------------------------------
2904 */
2905
2906int
2907TclCompileLsetCmd(
2908    Tcl_Interp *interp,         /* Tcl interpreter for error reporting. */
2909    Tcl_Parse *parsePtr,        /* Points to a parse structure for the
2910                                 * command. */
2911    Command *cmdPtr,            /* Points to defintion of command being
2912                                 * compiled. */
2913    CompileEnv *envPtr)         /* Holds the resulting instructions. */
2914{
2915    int tempDepth;              /* Depth used for emitting one part of the
2916                                 * code burst. */
2917    Tcl_Token *varTokenPtr;     /* Pointer to the Tcl_Token representing the
2918                                 * parse of the variable name. */
2919    int localIndex;             /* Index of var in local var table. */
2920    int simpleVarName;          /* Flag == 1 if var name is simple. */
2921    int isScalar;               /* Flag == 1 if scalar, 0 if array. */
2922    int i;
2923    DefineLineInformation;      /* TIP #280 */
2924
2925    /*
2926     * Check argument count.
2927     */
2928
2929    if (parsePtr->numWords < 3) {
2930        /*
2931         * Fail at run time, not in compilation.
2932         */
2933
2934        return TCL_ERROR;
2935    }
2936
2937    /*
2938     * Decide if we can use a frame slot for the var/array name or if we need
2939     * to emit code to compute and push the name at runtime. We use a frame
2940     * slot (entry in the array of local vars) if we are compiling a procedure
2941     * body and if the name is simple text that does not include namespace
2942     * qualifiers.
2943     */
2944
2945    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
2946    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
2947                &localIndex, &simpleVarName, &isScalar,
2948                mapPtr->loc[eclIndex].line[1]);
2949
2950    /*
2951     * Push the "index" args and the new element value.
2952     */
2953
2954    for (i=2 ; i<parsePtr->numWords ; ++i) {
2955        varTokenPtr = TokenAfter(varTokenPtr);
2956        CompileWord(envPtr, varTokenPtr, interp, i);
2957    }
2958
2959    /*
2960     * Duplicate the variable name if it's been pushed.
2961     */
2962
2963    if (!simpleVarName || localIndex < 0) {
2964        if (!simpleVarName || isScalar) {
2965            tempDepth = parsePtr->numWords - 2;
2966        } else {
2967            tempDepth = parsePtr->numWords - 1;
2968        }
2969        TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
2970    }
2971
2972    /*
2973     * Duplicate an array index if one's been pushed.
2974     */
2975
2976    if (simpleVarName && !isScalar) {
2977        if (localIndex < 0) {
2978            tempDepth = parsePtr->numWords - 1;
2979        } else {
2980            tempDepth = parsePtr->numWords - 2;
2981        }
2982        TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
2983    }
2984
2985    /*
2986     * Emit code to load the variable's value.
2987     */
2988
2989    if (!simpleVarName) {
2990        TclEmitOpcode(INST_LOAD_STK, envPtr);
2991    } else if (isScalar) {
2992        if (localIndex < 0) {
2993            TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
2994        } else if (localIndex < 0x100) {
2995            TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
2996        } else {
2997            TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
2998        }
2999    } else {
3000        if (localIndex < 0) {
3001            TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
3002        } else if (localIndex < 0x100) {
3003            TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
3004        } else {
3005            TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
3006        }
3007    }
3008
3009    /*
3010     * Emit the correct variety of 'lset' instruction.
3011     */
3012
3013    if (parsePtr->numWords == 4) {
3014        TclEmitOpcode(INST_LSET_LIST, envPtr);
3015    } else {
3016        TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
3017    }
3018
3019    /*
3020     * Emit code to put the value back in the variable.
3021     */
3022
3023    if (!simpleVarName) {
3024        TclEmitOpcode(INST_STORE_STK, envPtr);
3025    } else if (isScalar) {
3026        if (localIndex < 0) {
3027            TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
3028        } else if (localIndex < 0x100) {
3029            TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
3030        } else {
3031            TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
3032        }
3033    } else {
3034        if (localIndex < 0) {
3035            TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
3036        } else if (localIndex < 0x100) {
3037            TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
3038        } else {
3039            TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
3040        }
3041    }
3042
3043    return TCL_OK;
3044}
3045
3046/*
3047 *----------------------------------------------------------------------
3048 *
3049 * TclCompileRegexpCmd --
3050 *
3051 *      Procedure called to compile the "regexp" command.
3052 *
3053 * Results:
3054 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3055 *      evaluation to runtime.
3056 *
3057 * Side effects:
3058 *      Instructions are added to envPtr to execute the "regexp" command at
3059 *      runtime.
3060 *
3061 *----------------------------------------------------------------------
3062 */
3063
3064int
3065TclCompileRegexpCmd(
3066    Tcl_Interp *interp,         /* Tcl interpreter for error reporting. */
3067    Tcl_Parse *parsePtr,        /* Points to a parse structure for the
3068                                 * command. */
3069    Command *cmdPtr,            /* Points to defintion of command being
3070                                 * compiled. */
3071    CompileEnv *envPtr)         /* Holds the resulting instructions. */
3072{
3073    Tcl_Token *varTokenPtr;     /* Pointer to the Tcl_Token representing the
3074                                 * parse of the RE or string. */
3075    int i, len, nocase, exact, sawLast, simple;
3076    char *str;
3077    DefineLineInformation;      /* TIP #280 */
3078
3079    /*
3080     * We are only interested in compiling simple regexp cases. Currently
3081     * supported compile cases are:
3082     *   regexp ?-nocase? ?--? staticString $var
3083     *   regexp ?-nocase? ?--? {^staticString$} $var
3084     */
3085
3086    if (parsePtr->numWords < 3) {
3087        return TCL_ERROR;
3088    }
3089
3090    simple = 0;
3091    nocase = 0;
3092    sawLast = 0;
3093    varTokenPtr = parsePtr->tokenPtr;
3094
3095    /*
3096     * We only look for -nocase and -- as options. Everything else gets pushed
3097     * to runtime execution. This is different than regexp's runtime option
3098     * handling, but satisfies our stricter needs.
3099     */
3100
3101    for (i = 1; i < parsePtr->numWords - 2; i++) {
3102        varTokenPtr = TokenAfter(varTokenPtr);
3103        if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
3104            /*
3105             * Not a simple string, so punt to runtime.
3106             */
3107
3108            return TCL_ERROR;
3109        }
3110        str = (char *) varTokenPtr[1].start;
3111        len = varTokenPtr[1].size;
3112        if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
3113            sawLast++;
3114            i++;
3115            break;
3116        } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
3117            nocase = 1;
3118        } else {
3119            /*
3120             * Not an option we recognize.
3121             */
3122
3123            return TCL_ERROR;
3124        }
3125    }
3126
3127    if ((parsePtr->numWords - i) != 2) {
3128        /*
3129         * We don't support capturing to variables.
3130         */
3131
3132        return TCL_ERROR;
3133    }
3134
3135    /*
3136     * Get the regexp string. If it is not a simple string or can't be
3137     * converted to a glob pattern, push the word for the INST_REGEXP.
3138     * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
3139     */
3140
3141    varTokenPtr = TokenAfter(varTokenPtr);
3142
3143    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
3144        Tcl_DString ds;
3145
3146        str = (char *) varTokenPtr[1].start;
3147        len = varTokenPtr[1].size;
3148        /*
3149         * If it has a '-', it could be an incorrectly formed regexp command.
3150         */
3151
3152        if ((*str == '-') && !sawLast) {
3153            return TCL_ERROR;
3154        }
3155
3156        if (len == 0) {
3157            /*
3158             * The semantics of regexp are always match on re == "".
3159             */
3160
3161            PushLiteral(envPtr, "1", 1);
3162            return TCL_OK;
3163        }
3164
3165        /*
3166         * Attempt to convert pattern to glob.  If successful, push the
3167         * converted pattern as a literal.
3168         */
3169
3170        if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
3171                == TCL_OK) {
3172            simple = 1;
3173            PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
3174            Tcl_DStringFree(&ds);
3175        }
3176    }
3177
3178    if (!simple) {
3179        CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
3180    }
3181
3182    /*
3183     * Push the string arg.
3184     */
3185
3186    varTokenPtr = TokenAfter(varTokenPtr);
3187    CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
3188
3189    if (simple) {
3190        if (exact && !nocase) {
3191            TclEmitOpcode(INST_STR_EQ, envPtr);
3192        } else {
3193            TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
3194        }
3195    } else {
3196        /*
3197         * Pass correct RE compile flags.  We use only Int1 (8-bit), but
3198         * that handles all the flags we want to pass.
3199         * Don't use TCL_REG_NOSUB as we may have backrefs.
3200         */
3201        int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
3202        TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
3203    }
3204
3205    return TCL_OK;
3206}
3207
3208/*
3209 *----------------------------------------------------------------------
3210 *
3211 * TclCompileReturnCmd --
3212 *
3213 *      Procedure called to compile the "return" command.
3214 *
3215 * Results:
3216 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3217 *      evaluation to runtime.
3218 *
3219 * Side effects:
3220 *      Instructions are added to envPtr to execute the "return" command at
3221 *      runtime.
3222 *
3223 *----------------------------------------------------------------------
3224 */
3225
3226int
3227TclCompileReturnCmd(
3228    Tcl_Interp *interp,         /* Used for error reporting. */
3229    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3230                                 * created by Tcl_ParseCommand. */
3231    Command *cmdPtr,            /* Points to defintion of command being
3232                                 * compiled. */
3233    CompileEnv *envPtr)         /* Holds resulting instructions. */
3234{
3235    /*
3236     * General syntax: [return ?-option value ...? ?result?]
3237     * An even number of words means an explicit result argument is present.
3238     */
3239    int level, code, objc, size, status = TCL_OK;
3240    int numWords = parsePtr->numWords;
3241    int explicitResult = (0 == (numWords % 2));
3242    int numOptionWords = numWords - 1 - explicitResult;
3243    Tcl_Obj *returnOpts, **objv;
3244    Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
3245    DefineLineInformation;      /* TIP #280 */
3246
3247    /*
3248     * Check for special case which can always be compiled:
3249     *      return -options <opts> <msg>
3250     * Unlike the normal [return] compilation, this version does everything at
3251     * runtime so it can handle arbitrary words and not just literals. Note
3252     * that if INST_RETURN_STK wasn't already needed for something else
3253     * ('finally' clause processing) this piece of code would not be present.
3254     */
3255
3256    if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
3257            && (wordTokenPtr[1].size == 8)
3258            && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
3259        Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
3260        Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
3261
3262        CompileWord(envPtr, optsTokenPtr, interp, 2);
3263        CompileWord(envPtr, msgTokenPtr,  interp, 3);
3264        TclEmitOpcode(INST_RETURN_STK, envPtr);
3265        return TCL_OK;
3266    }
3267
3268    /*
3269     * Allocate some working space.
3270     */
3271
3272    objv = (Tcl_Obj **) TclStackAlloc(interp,
3273            numOptionWords * sizeof(Tcl_Obj *));
3274
3275    /*
3276     * Scan through the return options. If any are unknown at compile time,
3277     * there is no value in bytecompiling. Save the option values known in an
3278     * objv array for merging into a return options dictionary.
3279     */
3280
3281    for (objc = 0; objc < numOptionWords; objc++) {
3282        objv[objc] = Tcl_NewObj();
3283        Tcl_IncrRefCount(objv[objc]);
3284        if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
3285            objc++;
3286            status = TCL_ERROR;
3287            goto cleanup;
3288        }
3289        wordTokenPtr = TokenAfter(wordTokenPtr);
3290    }
3291    status = TclMergeReturnOptions(interp, objc, objv,
3292            &returnOpts, &code, &level);
3293  cleanup:
3294    while (--objc >= 0) {
3295        TclDecrRefCount(objv[objc]);
3296    }
3297    TclStackFree(interp, objv);
3298    if (TCL_ERROR == status) {
3299        /*
3300         * Something was bogus in the return options. Clear the error message,
3301         * and report back to the compiler that this must be interpreted at
3302         * runtime.
3303         */
3304
3305        Tcl_ResetResult(interp);
3306        return TCL_ERROR;
3307    }
3308
3309    /*
3310     * All options are known at compile time, so we're going to bytecompile.
3311     * Emit instructions to push the result on the stack.
3312     */
3313
3314    if (explicitResult) {
3315         CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
3316    } else {
3317        /*
3318         * No explict result argument, so default result is empty string.
3319         */
3320
3321        PushLiteral(envPtr, "", 0);
3322    }
3323
3324    /*
3325     * Check for optimization: When [return] is in a proc, and there's no
3326     * enclosing [catch], and there are no return options, then the INST_DONE
3327     * instruction is equivalent, and may be more efficient.
3328     */
3329
3330    if (numOptionWords == 0 && envPtr->procPtr != NULL) {
3331        /*
3332         * We have default return options and we're in a proc ...
3333         */
3334
3335        int index = envPtr->exceptArrayNext - 1;
3336        int enclosingCatch = 0;
3337
3338        while (index >= 0) {
3339            ExceptionRange range = envPtr->exceptArrayPtr[index];
3340            if ((range.type == CATCH_EXCEPTION_RANGE)
3341                    && (range.catchOffset == -1)) {
3342                enclosingCatch = 1;
3343                break;
3344            }
3345            index--;
3346        }
3347        if (!enclosingCatch) {
3348            /*
3349             * ... and there is no enclosing catch. Issue the maximally
3350             * efficient exit instruction.
3351             */
3352
3353            Tcl_DecrRefCount(returnOpts);
3354            TclEmitOpcode(INST_DONE, envPtr);
3355            return TCL_OK;
3356        }
3357    }
3358
3359    /* Optimize [return -level 0 $x]. */
3360    Tcl_DictObjSize(NULL, returnOpts, &size);
3361    if (size == 0 && level == 0 && code == TCL_OK) {
3362        Tcl_DecrRefCount(returnOpts);
3363        return TCL_OK;
3364    }
3365
3366    /*
3367     * Could not use the optimization, so we push the return options dict, and
3368     * emit the INST_RETURN_IMM instruction with code and level as operands.
3369     */
3370
3371    CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
3372    return TCL_OK;
3373}
3374
3375static void
3376CompileReturnInternal(
3377    CompileEnv *envPtr,
3378    unsigned char op,
3379    int code,
3380    int level,
3381    Tcl_Obj *returnOpts)
3382{
3383    TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
3384    TclEmitInstInt4(op, code, envPtr);
3385    TclEmitInt4(level, envPtr);
3386}
3387
3388void
3389TclCompileSyntaxError(
3390    Tcl_Interp *interp,
3391    CompileEnv *envPtr)
3392{
3393    Tcl_Obj *msg = Tcl_GetObjResult(interp);
3394    int numBytes;
3395    const char *bytes = TclGetStringFromObj(msg, &numBytes);
3396
3397    TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
3398    CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
3399            Tcl_GetReturnOptions(interp, TCL_ERROR));
3400}
3401
3402/*
3403 *----------------------------------------------------------------------
3404 *
3405 * TclCompileSetCmd --
3406 *
3407 *      Procedure called to compile the "set" command.
3408 *
3409 * Results:
3410 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3411 *      evaluation to runtime.
3412 *
3413 * Side effects:
3414 *      Instructions are added to envPtr to execute the "set" command at
3415 *      runtime.
3416 *
3417 *----------------------------------------------------------------------
3418 */
3419
3420int
3421TclCompileSetCmd(
3422    Tcl_Interp *interp,         /* Used for error reporting. */
3423    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3424                                 * created by Tcl_ParseCommand. */
3425    Command *cmdPtr,            /* Points to defintion of command being
3426                                 * compiled. */
3427    CompileEnv *envPtr)         /* Holds resulting instructions. */
3428{
3429    Tcl_Token *varTokenPtr, *valueTokenPtr;
3430    int isAssignment, isScalar, simpleVarName, localIndex, numWords;
3431    DefineLineInformation;      /* TIP #280 */
3432
3433    numWords = parsePtr->numWords;
3434    if ((numWords != 2) && (numWords != 3)) {
3435        return TCL_ERROR;
3436    }
3437    isAssignment = (numWords == 3);
3438
3439    /*
3440     * Decide if we can use a frame slot for the var/array name or if we need
3441     * to emit code to compute and push the name at runtime. We use a frame
3442     * slot (entry in the array of local vars) if we are compiling a procedure
3443     * body and if the name is simple text that does not include namespace
3444     * qualifiers.
3445     */
3446
3447    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
3448    PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
3449                &localIndex, &simpleVarName, &isScalar,
3450                mapPtr->loc[eclIndex].line[1]);
3451
3452    /*
3453     * If we are doing an assignment, push the new value.
3454     */
3455
3456    if (isAssignment) {
3457        valueTokenPtr = TokenAfter(varTokenPtr);
3458        CompileWord(envPtr, valueTokenPtr, interp, 2);
3459    }
3460
3461    /*
3462     * Emit instructions to set/get the variable.
3463     */
3464
3465    if (simpleVarName) {
3466        if (isScalar) {
3467            if (localIndex < 0) {
3468                TclEmitOpcode((isAssignment?
3469                        INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
3470            } else if (localIndex <= 255) {
3471                TclEmitInstInt1((isAssignment?
3472                        INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
3473                        localIndex, envPtr);
3474            } else {
3475                TclEmitInstInt4((isAssignment?
3476                        INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
3477                        localIndex, envPtr);
3478            }
3479        } else {
3480            if (localIndex < 0) {
3481                TclEmitOpcode((isAssignment?
3482                        INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
3483            } else if (localIndex <= 255) {
3484                TclEmitInstInt1((isAssignment?
3485                        INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
3486                        localIndex, envPtr);
3487            } else {
3488                TclEmitInstInt4((isAssignment?
3489                        INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
3490                        localIndex, envPtr);
3491            }
3492        }
3493    } else {
3494        TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
3495    }
3496
3497    return TCL_OK;
3498}
3499
3500/*
3501 *----------------------------------------------------------------------
3502 *
3503 * TclCompileStringCmpCmd --
3504 *
3505 *      Procedure called to compile the simplest and most common form of the
3506 *      "string compare" command.
3507 *
3508 * Results:
3509 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3510 *      evaluation to runtime.
3511 *
3512 * Side effects:
3513 *      Instructions are added to envPtr to execute the "string compare"
3514 *      command at runtime.
3515 *
3516 *----------------------------------------------------------------------
3517 */
3518
3519int
3520TclCompileStringCmpCmd(
3521    Tcl_Interp *interp,         /* Used for error reporting. */
3522    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3523                                 * created by Tcl_ParseCommand. */
3524    Command *cmdPtr,            /* Points to defintion of command being
3525                                 * compiled. */
3526    CompileEnv *envPtr)         /* Holds resulting instructions. */
3527{
3528    DefineLineInformation;      /* TIP #280 */
3529    Tcl_Token *tokenPtr;
3530
3531    /*
3532     * We don't support any flags; the bytecode isn't that sophisticated.
3533     */
3534
3535    if (parsePtr->numWords != 3) {
3536        return TCL_ERROR;
3537    }
3538
3539    /*
3540     * Push the two operands onto the stack and then the test.
3541     */
3542
3543    tokenPtr = TokenAfter(parsePtr->tokenPtr);
3544    CompileWord(envPtr, tokenPtr, interp, 1);
3545    tokenPtr = TokenAfter(tokenPtr);
3546    CompileWord(envPtr, tokenPtr, interp, 2);
3547    TclEmitOpcode(INST_STR_CMP, envPtr);
3548    return TCL_OK;
3549}
3550
3551/*
3552 *----------------------------------------------------------------------
3553 *
3554 * TclCompileStringEqualCmd --
3555 *
3556 *      Procedure called to compile the simplest and most common form of the
3557 *      "string equal" command.
3558 *
3559 * Results:
3560 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3561 *      evaluation to runtime.
3562 *
3563 * Side effects:
3564 *      Instructions are added to envPtr to execute the "string equal" command
3565 *      at runtime.
3566 *
3567 *----------------------------------------------------------------------
3568 */
3569
3570int
3571TclCompileStringEqualCmd(
3572    Tcl_Interp *interp,         /* Used for error reporting. */
3573    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3574                                 * created by Tcl_ParseCommand. */
3575    Command *cmdPtr,            /* Points to defintion of command being
3576                                 * compiled. */
3577    CompileEnv *envPtr)         /* Holds resulting instructions. */
3578{
3579    DefineLineInformation;      /* TIP #280 */
3580    Tcl_Token *tokenPtr;
3581
3582    /*
3583     * We don't support any flags; the bytecode isn't that sophisticated.
3584     */
3585
3586    if (parsePtr->numWords != 3) {
3587        return TCL_ERROR;
3588    }
3589
3590    /*
3591     * Push the two operands onto the stack and then the test.
3592     */
3593
3594    tokenPtr = TokenAfter(parsePtr->tokenPtr);
3595    CompileWord(envPtr, tokenPtr, interp, 1);
3596    tokenPtr = TokenAfter(tokenPtr);
3597    CompileWord(envPtr, tokenPtr, interp, 2);
3598    TclEmitOpcode(INST_STR_EQ, envPtr);
3599    return TCL_OK;
3600}
3601
3602/*
3603 *----------------------------------------------------------------------
3604 *
3605 * TclCompileStringIndexCmd --
3606 *
3607 *      Procedure called to compile the simplest and most common form of the
3608 *      "string index" command.
3609 *
3610 * Results:
3611 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3612 *      evaluation to runtime.
3613 *
3614 * Side effects:
3615 *      Instructions are added to envPtr to execute the "string index" command
3616 *      at runtime.
3617 *
3618 *----------------------------------------------------------------------
3619 */
3620
3621int
3622TclCompileStringIndexCmd(
3623    Tcl_Interp *interp,         /* Used for error reporting. */
3624    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3625                                 * created by Tcl_ParseCommand. */
3626    Command *cmdPtr,            /* Points to defintion of command being
3627                                 * compiled. */
3628    CompileEnv *envPtr)         /* Holds resulting instructions. */
3629{
3630    DefineLineInformation;      /* TIP #280 */
3631    Tcl_Token *tokenPtr;
3632
3633    if (parsePtr->numWords != 3) {
3634        return TCL_ERROR;
3635    }
3636
3637    /*
3638     * Push the two operands onto the stack and then the index operation.
3639     */
3640
3641    tokenPtr = TokenAfter(parsePtr->tokenPtr);
3642    CompileWord(envPtr, tokenPtr, interp, 1);
3643    tokenPtr = TokenAfter(tokenPtr);
3644    CompileWord(envPtr, tokenPtr, interp, 2);
3645    TclEmitOpcode(INST_STR_INDEX, envPtr);
3646    return TCL_OK;
3647}
3648
3649/*
3650 *----------------------------------------------------------------------
3651 *
3652 * TclCompileStringMatchCmd --
3653 *
3654 *      Procedure called to compile the simplest and most common form of the
3655 *      "string match" command.
3656 *
3657 * Results:
3658 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3659 *      evaluation to runtime.
3660 *
3661 * Side effects:
3662 *      Instructions are added to envPtr to execute the "string match" command
3663 *      at runtime.
3664 *
3665 *----------------------------------------------------------------------
3666 */
3667
3668int
3669TclCompileStringMatchCmd(
3670    Tcl_Interp *interp,         /* Used for error reporting. */
3671    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3672                                 * created by Tcl_ParseCommand. */
3673    Command *cmdPtr,            /* Points to defintion of command being
3674                                 * compiled. */
3675    CompileEnv *envPtr)         /* Holds resulting instructions. */
3676{
3677    DefineLineInformation;      /* TIP #280 */
3678    Tcl_Token *tokenPtr;
3679    int i, length, exactMatch = 0, nocase = 0;
3680    const char *str;
3681
3682    if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
3683        return TCL_ERROR;
3684    }
3685    tokenPtr = TokenAfter(parsePtr->tokenPtr);
3686
3687    /*
3688     * Check if we have a -nocase flag.
3689     */
3690
3691    if (parsePtr->numWords == 4) {
3692        if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
3693            return TCL_ERROR;
3694        }
3695        str = tokenPtr[1].start;
3696        length = tokenPtr[1].size;
3697        if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
3698            /*
3699             * Fail at run time, not in compilation.
3700             */
3701
3702            return TCL_ERROR;
3703        }
3704        nocase = 1;
3705        tokenPtr = TokenAfter(tokenPtr);
3706    }
3707
3708    /*
3709     * Push the strings to match against each other.
3710     */
3711
3712    for (i = 0; i < 2; i++) {
3713        if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
3714            str = tokenPtr[1].start;
3715            length = tokenPtr[1].size;
3716            if (!nocase && (i == 0)) {
3717                /*
3718                 * Trivial matches can be done by 'string equal'. If -nocase
3719                 * was specified, we can't do this because INST_STR_EQ has no
3720                 * support for nocase.
3721                 */
3722
3723                Tcl_Obj *copy = Tcl_NewStringObj(str, length);
3724
3725                Tcl_IncrRefCount(copy);
3726                exactMatch = TclMatchIsTrivial(TclGetString(copy));
3727                TclDecrRefCount(copy);
3728            }
3729            PushLiteral(envPtr, str, length);
3730        } else {
3731            envPtr->line = mapPtr->loc[eclIndex].line[i+1+nocase];
3732            CompileTokens(envPtr, tokenPtr, interp);
3733        }
3734        tokenPtr = TokenAfter(tokenPtr);
3735    }
3736
3737    /*
3738     * Push the matcher.
3739     */
3740
3741    if (exactMatch) {
3742        TclEmitOpcode(INST_STR_EQ, envPtr);
3743    } else {
3744        TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
3745    }
3746    return TCL_OK;
3747}
3748
3749/*
3750 *----------------------------------------------------------------------
3751 *
3752 * TclCompileStringLenCmd --
3753 *
3754 *      Procedure called to compile the simplest and most common form of the
3755 *      "string length" command.
3756 *
3757 * Results:
3758 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
3759 *      evaluation to runtime.
3760 *
3761 * Side effects:
3762 *      Instructions are added to envPtr to execute the "string length"
3763 *      command at runtime.
3764 *
3765 *----------------------------------------------------------------------
3766 */
3767
3768int
3769TclCompileStringLenCmd(
3770    Tcl_Interp *interp,         /* Used for error reporting. */
3771    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3772                                 * created by Tcl_ParseCommand. */
3773    Command *cmdPtr,            /* Points to defintion of command being
3774                                 * compiled. */
3775    CompileEnv *envPtr)         /* Holds resulting instructions. */
3776{
3777    DefineLineInformation;      /* TIP #280 */
3778    Tcl_Token *tokenPtr;
3779
3780    if (parsePtr->numWords != 2) {
3781        return TCL_ERROR;
3782    }
3783
3784    tokenPtr = TokenAfter(parsePtr->tokenPtr);
3785    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
3786        /*
3787         * Here someone is asking for the length of a static string. Just push
3788         * the actual character (not byte) length.
3789         */
3790
3791        char buf[TCL_INTEGER_SPACE];
3792        int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size);
3793
3794        len = sprintf(buf, "%d", len);
3795        PushLiteral(envPtr, buf, len);
3796    } else {
3797        envPtr->line = mapPtr->loc[eclIndex].line[1];
3798        CompileTokens(envPtr, tokenPtr, interp);
3799        TclEmitOpcode(INST_STR_LEN, envPtr);
3800    }
3801    return TCL_OK;
3802}
3803
3804/*
3805 *----------------------------------------------------------------------
3806 *
3807 * TclCompileSwitchCmd --
3808 *
3809 *      Procedure called to compile the "switch" command.
3810 *
3811 * Results:
3812 *      Returns TCL_OK for successful compile, or TCL_ERROR to defer
3813 *      evaluation to runtime (either when it is too complex to get the
3814 *      semantics right, or when we know for sure that it is an error but need
3815 *      the error to happen at the right time).
3816 *
3817 * Side effects:
3818 *      Instructions are added to envPtr to execute the "switch" command at
3819 *      runtime.
3820 *
3821 * FIXME:
3822 *      Stack depths are probably not calculated correctly.
3823 *
3824 *----------------------------------------------------------------------
3825 */
3826
3827int
3828TclCompileSwitchCmd(
3829    Tcl_Interp *interp,         /* Used for error reporting. */
3830    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3831                                 * created by Tcl_ParseCommand. */
3832    Command *cmdPtr,            /* Points to defintion of command being
3833                                 * compiled. */
3834    CompileEnv *envPtr)         /* Holds resulting instructions. */
3835{
3836    Tcl_Token *tokenPtr;        /* Pointer to tokens in command. */
3837    int numWords;               /* Number of words in command. */
3838
3839    Tcl_Token *valueTokenPtr;   /* Token for the value to switch on. */
3840    enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
3841                                /* What kind of switch are we doing? */
3842
3843    Tcl_Token *bodyTokenArray;  /* Array of real pattern list items. */
3844    Tcl_Token **bodyToken;      /* Array of pointers to pattern list items. */
3845    int *bodyLines;             /* Array of line numbers for body list
3846                                 * items. */
3847    int foundDefault;           /* Flag to indicate whether a "default" clause
3848                                 * is present. */
3849
3850    JumpFixup *fixupArray;      /* Array of forward-jump fixup records. */
3851    int *fixupTargetArray;      /* Array of places for fixups to point at. */
3852    int fixupCount;             /* Number of places to fix up. */
3853    int contFixIndex;           /* Where the first of the jumps due to a group
3854                                 * of continuation bodies starts, or -1 if
3855                                 * there aren't any. */
3856    int contFixCount;           /* Number of continuation bodies pointing to
3857                                 * the current (or next) real body. */
3858
3859    int savedStackDepth = envPtr->currStackDepth;
3860    int noCase;                 /* Has the -nocase flag been given? */
3861    int foundMode = 0;          /* Have we seen a mode flag yet? */
3862    int isListedArms = 0;
3863    int i, valueIndex;
3864    DefineLineInformation;      /* TIP #280 */
3865
3866    /*
3867     * Only handle the following versions:
3868     *   switch         ?--? word {pattern body ...}
3869     *   switch -exact  ?--? word {pattern body ...}
3870     *   switch -glob   ?--? word {pattern body ...}
3871     *   switch -regexp ?--? word {pattern body ...}
3872     *   switch         --   word simpleWordPattern simpleWordBody ...
3873     *   switch -exact  --   word simpleWordPattern simpleWordBody ...
3874     *   switch -glob   --   word simpleWordPattern simpleWordBody ...
3875     *   switch -regexp --   word simpleWordPattern simpleWordBody ...
3876     * When the mode is -glob, can also handle a -nocase flag.
3877     *
3878     * First off, we don't care how the command's word was generated; we're
3879     * compiling it anyway! So skip it...
3880     */
3881
3882    tokenPtr = TokenAfter(parsePtr->tokenPtr);
3883    valueIndex = 1;
3884    numWords = parsePtr->numWords-1;
3885
3886    /*
3887     * Check for options.
3888     */
3889
3890    noCase = 0;
3891    mode = Switch_Exact;
3892    if (numWords == 2) {
3893        /*
3894         * There's just the switch value and the bodies list. In that case, we
3895         * can skip all option parsing and move on to consider switch values
3896         * and the body list.
3897         */
3898
3899        goto finishedOptionParse;
3900    }
3901
3902    /*
3903     * There must be at least one option, --, because without that there is no
3904     * way to statically avoid the problems you get from strings-to-be-matched
3905     * that start with a - (the interpreted code falls apart if it encounters
3906     * them, so we punt if we *might* encounter them as that is the easiest
3907     * way of emulating the behaviour).
3908     */
3909
3910    for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
3911        register unsigned size = tokenPtr[1].size;
3912        register const char *chrs = tokenPtr[1].start;
3913
3914        /*
3915         * We only process literal options, and we assume that -e, -g and -n
3916         * are unique prefixes of -exact, -glob and -nocase respectively (true
3917         * at time of writing). Note that -exact and -glob may only be given
3918         * at most once or we bail out (error case).
3919         */
3920
3921        if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
3922            return TCL_ERROR;
3923        }
3924
3925        if ((size <= 6) && !memcmp(chrs, "-exact", size)) {
3926            if (foundMode) {
3927                return TCL_ERROR;
3928            }
3929            mode = Switch_Exact;
3930            foundMode = 1;
3931            valueIndex++;
3932            continue;
3933        } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) {
3934            if (foundMode) {
3935                return TCL_ERROR;
3936            }
3937            mode = Switch_Glob;
3938            foundMode = 1;
3939            valueIndex++;
3940            continue;
3941        } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) {
3942            if (foundMode) {
3943                return TCL_ERROR;
3944            }
3945            mode = Switch_Regexp;
3946            foundMode = 1;
3947            valueIndex++;
3948            continue;
3949        } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) {
3950            noCase = 1;
3951            valueIndex++;
3952            continue;
3953        } else if ((size == 2) && !memcmp(chrs, "--", 2)) {
3954            valueIndex++;
3955            break;
3956        }
3957
3958        /*
3959         * The switch command has many flags we cannot compile at all (e.g.
3960         * all the RE-related ones) which we must have encountered. Either
3961         * that or we have run off the end. The action here is the same: punt
3962         * to interpreted version.
3963         */
3964
3965        return TCL_ERROR;
3966    }
3967    if (numWords < 3) {
3968        return TCL_ERROR;
3969    }
3970    tokenPtr = TokenAfter(tokenPtr);
3971    numWords--;
3972    if (noCase && (mode == Switch_Exact)) {
3973        /*
3974         * Can't compile this case; no opcode for case-insensitive equality!
3975         */
3976
3977        return TCL_ERROR;
3978    }
3979
3980    /*
3981     * The value to test against is going to always get pushed on the stack.
3982     * But not yet; we need to verify that the rest of the command is
3983     * compilable too.
3984     */
3985
3986  finishedOptionParse:
3987    valueTokenPtr = tokenPtr;
3988    /* For valueIndex, see previous loop. */
3989    tokenPtr = TokenAfter(tokenPtr);
3990    numWords--;
3991
3992    /*
3993     * Build an array of tokens for the matcher terms and script bodies. Note
3994     * that in the case of the quoted bodies, this is tricky as we cannot use
3995     * copies of the string from the input token for the generated tokens (it
3996     * causes a crash during exception handling). When multiple tokens are
3997     * available at this point, this is pretty easy.
3998     */
3999
4000    if (numWords == 1) {
4001        Tcl_DString bodyList;
4002        const char **argv = NULL, *tokenStartPtr, *p;
4003        int bline;              /* TIP #280: line of the pattern/action list,
4004                                 * and start of list for when tracking the
4005                                 * location. This list comes immediately after
4006                                 * the value we switch on. */
4007        int isTokenBraced;
4008
4009        /*
4010         * Test that we've got a suitable body list as a simple (i.e. braced)
4011         * word, and that the elements of the body are simple words too. This
4012         * is really rather nasty indeed.
4013         */
4014
4015        if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
4016            return TCL_ERROR;
4017        }
4018
4019        Tcl_DStringInit(&bodyList);
4020        Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size);
4021        if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords,
4022                &argv) != TCL_OK) {
4023            Tcl_DStringFree(&bodyList);
4024            return TCL_ERROR;
4025        }
4026        Tcl_DStringFree(&bodyList);
4027
4028        /*
4029         * Now we know what the switch arms are, we've got to see whether we
4030         * can synthesize tokens for the arms. First check whether we've got a
4031         * valid number of arms since we can do that now.
4032         */
4033
4034        if (numWords == 0 || numWords % 2) {
4035            ckfree((char *) argv);
4036            return TCL_ERROR;
4037        }
4038
4039        isListedArms = 1;
4040        bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords);
4041        bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
4042        bodyLines = (int *) ckalloc(sizeof(int) * numWords);
4043
4044        /*
4045         * Locate the start of the arms within the overall word.
4046         */
4047
4048        bline = mapPtr->loc[eclIndex].line[valueIndex+1];
4049        p = tokenStartPtr = tokenPtr[1].start;
4050        while (isspace(UCHAR(*tokenStartPtr))) {
4051            tokenStartPtr++;
4052        }
4053        if (*tokenStartPtr == '{') {
4054            tokenStartPtr++;
4055            isTokenBraced = 1;
4056        } else {
4057            isTokenBraced = 0;
4058        }
4059
4060        /*
4061         * TIP #280: Count lines within the literal list.
4062         */
4063
4064        for (i=0 ; i<numWords ; i++) {
4065            bodyTokenArray[i].type = TCL_TOKEN_TEXT;
4066            bodyTokenArray[i].start = tokenStartPtr;
4067            bodyTokenArray[i].size = strlen(argv[i]);
4068            bodyTokenArray[i].numComponents = 0;
4069            bodyToken[i] = bodyTokenArray+i;
4070            tokenStartPtr += bodyTokenArray[i].size;
4071
4072            /*
4073             * Test to see if we have guessed the end of the word correctly;
4074             * if not, we can't feed the real string to the sub-compilation
4075             * engine, and we're then stuck and so have to punt out to doing
4076             * everything at runtime.
4077             */
4078
4079            if ((isTokenBraced && *(tokenStartPtr++) != '}') ||
4080                    (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size
4081                    && !isspace(UCHAR(*tokenStartPtr)))) {
4082                ckfree((char *) argv);
4083                ckfree((char *) bodyToken);
4084                ckfree((char *) bodyTokenArray);
4085                ckfree((char *) bodyLines);
4086                return TCL_ERROR;
4087            }
4088
4089            /*
4090             * TIP #280: Now determine the line the list element starts on
4091             * (there is no need to do it earlier, due to the possibility of
4092             * aborting, see above).
4093             */
4094
4095            TclAdvanceLines(&bline, p, bodyTokenArray[i].start);
4096            bodyLines[i] = bline;
4097            p = bodyTokenArray[i].start;
4098
4099            while (isspace(UCHAR(*tokenStartPtr))) {
4100                tokenStartPtr++;
4101                if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) {
4102                    break;
4103                }
4104            }
4105            if (*tokenStartPtr == '{') {
4106                tokenStartPtr++;
4107                isTokenBraced = 1;
4108            } else {
4109                isTokenBraced = 0;
4110            }
4111        }
4112        ckfree((char *) argv);
4113
4114        /*
4115         * Check that we've parsed everything we thought we were going to
4116         * parse. If not, something odd is going on (I believe it is possible
4117         * to defeat the code above) and we should bail out.
4118         */
4119
4120        if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) {
4121            ckfree((char *) bodyToken);
4122            ckfree((char *) bodyTokenArray);
4123            ckfree((char *) bodyLines);
4124            return TCL_ERROR;
4125        }
4126
4127    } else if (numWords % 2 || numWords == 0) {
4128        /*
4129         * Odd number of words (>1) available, or no words at all available.
4130         * Both are error cases, so punt and let the interpreted-version
4131         * generate the error message. Note that the second case probably
4132         * should get caught earlier, but it's easy to check here again anyway
4133         * because it'd cause a nasty crash otherwise.
4134         */
4135
4136        return TCL_ERROR;
4137    } else {
4138        /*
4139         * Multi-word definition of patterns & actions.
4140         */
4141
4142        bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
4143        bodyLines = (int *) ckalloc(sizeof(int) * numWords);
4144        bodyTokenArray = NULL;
4145        for (i=0 ; i<numWords ; i++) {
4146            /*
4147             * We only handle the very simplest case. Anything more complex is
4148             * a good reason to go to the interpreted case anyway due to
4149             * traces, etc.
4150             */
4151
4152            if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
4153                    tokenPtr->numComponents != 1) {
4154                ckfree((char *) bodyToken);
4155                ckfree((char *) bodyLines);
4156                return TCL_ERROR;
4157            }
4158            bodyToken[i] = tokenPtr+1;
4159
4160            /*
4161             * TIP #280: Copy line information from regular cmd info.
4162             */
4163
4164            bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
4165            tokenPtr = TokenAfter(tokenPtr);
4166        }
4167    }
4168
4169    /*
4170     * Fall back to interpreted if the last body is a continuation (it's
4171     * illegal, but this makes the error happen at the right time).
4172     */
4173
4174    if (bodyToken[numWords-1]->size == 1 &&
4175            bodyToken[numWords-1]->start[0] == '-') {
4176        ckfree((char *) bodyToken);
4177        ckfree((char *) bodyLines);
4178        if (bodyTokenArray != NULL) {
4179            ckfree((char *) bodyTokenArray);
4180        }
4181        return TCL_ERROR;
4182    }
4183
4184    /*
4185     * Now we commit to generating code; the parsing stage per se is done.
4186     * First, we push the value we're matching against on the stack.
4187     */
4188
4189    envPtr->line = mapPtr->loc[eclIndex].line[valueIndex];
4190    CompileTokens(envPtr, valueTokenPtr, interp);
4191
4192    /*
4193     * Check if we can generate a jump table, since if so that's faster than
4194     * doing an explicit compare with each body. Note that we're definitely
4195     * over-conservative with determining whether we can do the jump table,
4196     * but it handles the most common case well enough.
4197     */
4198
4199    if (isListedArms && mode == Switch_Exact && !noCase) {
4200        JumptableInfo *jtPtr;
4201        int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
4202        int mustGenerate, jumpToDefault;
4203        Tcl_DString buffer;
4204        Tcl_HashEntry *hPtr;
4205
4206        /*
4207         * Compile the switch by using a jump table, which is basically a
4208         * hashtable that maps from literal values to match against to the
4209         * offset (relative to the INST_JUMP_TABLE instruction) to jump to.
4210         * The jump table itself is independent of any invokation of the
4211         * bytecode, and as such is stored in an auxData block.
4212         *
4213         * Start by allocating the jump table itself, plus some workspace.
4214         */
4215
4216        jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo));
4217        Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
4218        infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
4219        finalFixups = (int *) ckalloc(sizeof(int) * (numWords/2));
4220        foundDefault = 0;
4221        mustGenerate = 1;
4222
4223        /*
4224         * Next, issue the instruction to do the jump, together with what we
4225         * want to do if things do not work out (jump to either the default
4226         * clause or the "default" default, which just sets the result to
4227         * empty). Note that we will come back and rewrite the jump's offset
4228         * parameter when we know what it should be, and that all jumps we
4229         * issue are of the wide kind because that makes the code much easier
4230         * to debug!
4231         */
4232
4233        jumpLocation = CurrentOffset(envPtr);
4234        TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr);
4235        jumpToDefault = CurrentOffset(envPtr);
4236        TclEmitInstInt4(INST_JUMP4, 0, envPtr);
4237
4238        for (i=0 ; i<numWords ; i+=2) {
4239            /*
4240             * For each arm, we must first work out what to do with the match
4241             * term.
4242             */
4243
4244            if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
4245                    memcmp(bodyToken[numWords-2]->start, "default", 7)) {
4246                /*
4247                 * This is not a default clause, so insert the current
4248                 * location as a target in the jump table (assuming it isn't
4249                 * already there, which would indicate that this clause is
4250                 * probably masked by an earlier one). Note that we use a
4251                 * Tcl_DString here simply because the hash API does not let
4252                 * us specify the string length.
4253                 */
4254
4255                Tcl_DStringInit(&buffer);
4256                Tcl_DStringAppend(&buffer, bodyToken[i]->start,
4257                        bodyToken[i]->size);
4258                hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
4259                        Tcl_DStringValue(&buffer), &isNew);
4260                if (isNew) {
4261                    /*
4262                     * First time we've encountered this match clause, so it
4263                     * must point to here.
4264                     */
4265
4266                    Tcl_SetHashValue(hPtr, (ClientData)
4267                            (CurrentOffset(envPtr) - jumpLocation));
4268                }
4269                Tcl_DStringFree(&buffer);
4270            } else {
4271                /*
4272                 * This is a default clause, so patch up the fallthrough from
4273                 * the INST_JUMP_TABLE instruction to here.
4274                 */
4275
4276                foundDefault = 1;
4277                isNew = 1;
4278                TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
4279                        envPtr->codeStart+jumpToDefault+1);
4280            }
4281
4282            /*
4283             * Now, for each arm we must deal with the body of the clause.
4284             *
4285             * If this is a continuation body (never true of a final clause,
4286             * whether default or not) we're done because the next jump target
4287             * will also point here, so we advance to the next clause.
4288             */
4289
4290            if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') {
4291                mustGenerate = 1;
4292                continue;
4293            }
4294
4295            /*
4296             * Also skip this arm if its only match clause is masked. (We
4297             * could probably be more aggressive about this, but that would be
4298             * much more difficult to get right.)
4299             */
4300
4301            if (!isNew && !mustGenerate) {
4302                continue;
4303            }
4304            mustGenerate = 0;
4305
4306            /*
4307             * Compile the body of the arm.
4308             */
4309
4310            envPtr->line = bodyLines[i+1];      /* TIP #280 */
4311            TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
4312
4313            /*
4314             * Compile a jump in to the end of the command if this body is
4315             * anything other than a user-supplied default arm (to either skip
4316             * over the remaining bodies or the code that generates an empty
4317             * result).
4318             */
4319
4320            if (i+2 < numWords || !foundDefault) {
4321                finalFixups[numRealBodies++] = CurrentOffset(envPtr);
4322
4323                /*
4324                 * Easier by far to issue this jump as a fixed-width jump.
4325                 * Otherwise we'd need to do a lot more (and more awkward)
4326                 * rewriting when we fixed this all up.
4327                 */
4328
4329                TclEmitInstInt4(INST_JUMP4, 0, envPtr);
4330            }
4331        }
4332
4333        /*
4334         * We're at the end. If we've not already done so through the
4335         * processing of a user-supplied default clause, add in a "default"
4336         * default clause now.
4337         */
4338
4339        if (!foundDefault) {
4340            TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
4341                    envPtr->codeStart+jumpToDefault+1);
4342            PushLiteral(envPtr, "", 0);
4343        }
4344
4345        /*
4346         * No more instructions to be issued; everything that needs to jump to
4347         * the end of the command is fixed up at this point.
4348         */
4349
4350        for (i=0 ; i<numRealBodies ; i++) {
4351            TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i],
4352                    envPtr->codeStart+finalFixups[i]+1);
4353        }
4354
4355        /*
4356         * Clean up all our temporary space and return.
4357         */
4358
4359        ckfree((char *) finalFixups);
4360        ckfree((char *) bodyToken);
4361        ckfree((char *) bodyLines);
4362        if (bodyTokenArray != NULL) {
4363            ckfree((char *) bodyTokenArray);
4364        }
4365        return TCL_OK;
4366    }
4367
4368    /*
4369     * Generate a test for each arm.
4370     */
4371
4372    contFixIndex = -1;
4373    contFixCount = 0;
4374    fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords);
4375    fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords);
4376    memset(fixupTargetArray, 0, numWords * sizeof(int));
4377    fixupCount = 0;
4378    foundDefault = 0;
4379    for (i=0 ; i<numWords ; i+=2) {
4380        int nextArmFixupIndex = -1;
4381
4382        envPtr->currStackDepth = savedStackDepth + 1;
4383        if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
4384                memcmp(bodyToken[numWords-2]->start, "default", 7)) {
4385            /*
4386             * Generate the test for the arm.
4387             */
4388
4389            switch (mode) {
4390            case Switch_Exact:
4391                TclEmitOpcode(INST_DUP, envPtr);
4392                TclCompileTokens(interp, bodyToken[i], 1, envPtr);
4393                TclEmitOpcode(INST_STR_EQ, envPtr);
4394                break;
4395            case Switch_Glob:
4396                TclCompileTokens(interp, bodyToken[i], 1, envPtr);
4397                TclEmitInstInt4(INST_OVER, 1, envPtr);
4398                TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
4399                break;
4400            case Switch_Regexp: {
4401                int simple = 0, exact = 0;
4402
4403                /*
4404                 * Keep in sync with TclCompileRegexpCmd.
4405                 */
4406
4407                if (bodyToken[i]->type == TCL_TOKEN_TEXT) {
4408                    Tcl_DString ds;
4409
4410                    if (bodyToken[i]->size == 0) {
4411                        /*
4412                         * The semantics of regexps are that they always match
4413                         * when the RE == "".
4414                         */
4415
4416                        PushLiteral(envPtr, "1", 1);
4417                        break;
4418                    }
4419
4420                    /*
4421                     * Attempt to convert pattern to glob. If successful, push
4422                     * the converted pattern.
4423                     */
4424
4425                    if (TclReToGlob(NULL, bodyToken[i]->start,
4426                            bodyToken[i]->size, &ds, &exact) == TCL_OK) {
4427                        simple = 1;
4428                        PushLiteral(envPtr, Tcl_DStringValue(&ds),
4429                                Tcl_DStringLength(&ds));
4430                        Tcl_DStringFree(&ds);
4431                    }
4432                }
4433                if (!simple) {
4434                    TclCompileTokens(interp, bodyToken[i], 1, envPtr);
4435                }
4436
4437                TclEmitInstInt4(INST_OVER, 1, envPtr);
4438                if (simple) {
4439                    if (exact && !noCase) {
4440                        TclEmitOpcode(INST_STR_EQ, envPtr);
4441                    } else {
4442                        TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
4443                    }
4444                } else {
4445                    /*
4446                     * Pass correct RE compile flags. We use only Int1
4447                     * (8-bit), but that handles all the flags we want to
4448                     * pass. Don't use TCL_REG_NOSUB as we may have backrefs
4449                     * or capture vars.
4450                     */
4451
4452                    int cflags = TCL_REG_ADVANCED
4453                            | (noCase ? TCL_REG_NOCASE : 0);
4454
4455                    TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
4456                }
4457                break;
4458            }
4459            default:
4460                Tcl_Panic("unknown switch mode: %d", mode);
4461            }
4462
4463            /*
4464             * In a fall-through case, we will jump on _true_ to the place
4465             * where the body starts (generated later, with guarantee of this
4466             * ensured earlier; the final body is never a fall-through).
4467             */
4468
4469            if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') {
4470                if (contFixIndex == -1) {
4471                    contFixIndex = fixupCount;
4472                    contFixCount = 0;
4473                }
4474                TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
4475                        fixupArray+contFixIndex+contFixCount);
4476                fixupCount++;
4477                contFixCount++;
4478                continue;
4479            }
4480
4481            TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount);
4482            nextArmFixupIndex = fixupCount;
4483            fixupCount++;
4484        } else {
4485            /*
4486             * Got a default clause; set a flag to inhibit the generation of
4487             * the jump after the body and the cleanup of the intermediate
4488             * value that we are switching against.
4489             *
4490             * Note that default clauses (which are always terminal clauses)
4491             * cannot be fall-through clauses as well, since the last clause
4492             * is never a fall-through clause (which we have already
4493             * verified).
4494             */
4495
4496            foundDefault = 1;
4497        }
4498
4499        /*
4500         * Generate the body for the arm. This is guaranteed not to be a
4501         * fall-through case, but it might have preceding fall-through cases,
4502         * so we must process those first.
4503         */
4504
4505        if (contFixIndex != -1) {
4506            int j;
4507
4508            for (j=0 ; j<contFixCount ; j++) {
4509                fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr);
4510            }
4511            contFixIndex = -1;
4512        }
4513
4514        /*
4515         * Now do the actual compilation. Note that we do not use CompileBody
4516         * because we may have synthesized the tokens in a non-standard
4517         * pattern.
4518         */
4519
4520        TclEmitOpcode(INST_POP, envPtr);
4521        envPtr->currStackDepth = savedStackDepth + 1;
4522        envPtr->line = bodyLines[i+1];          /* TIP #280 */
4523        TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
4524
4525        if (!foundDefault) {
4526            TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
4527                    fixupArray+fixupCount);
4528            fixupCount++;
4529            fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
4530        }
4531    }
4532
4533    /*
4534     * Clean up all our temporary space and return.
4535     */
4536
4537    ckfree((char *) bodyToken);
4538    ckfree((char *) bodyLines);
4539    if (bodyTokenArray != NULL) {
4540        ckfree((char *) bodyTokenArray);
4541    }
4542
4543    /*
4544     * Discard the value we are matching against unless we've had a default
4545     * clause (in which case it will already be gone due to the code at the
4546     * start of processing an arm, guaranteed) and make the result of the
4547     * command an empty string.
4548     */
4549
4550    if (!foundDefault) {
4551        TclEmitOpcode(INST_POP, envPtr);
4552        PushLiteral(envPtr, "", 0);
4553    }
4554
4555    /*
4556     * Do jump fixups for arms that were executed. First, fill in the jumps of
4557     * all jumps that don't point elsewhere to point to here.
4558     */
4559
4560    for (i=0 ; i<fixupCount ; i++) {
4561        if (fixupTargetArray[i] == 0) {
4562            fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
4563        }
4564    }
4565
4566    /*
4567     * Now scan backwards over all the jumps (all of which are forward jumps)
4568     * doing each one. When we do one and there is a size changes, we must
4569     * scan back over all the previous ones and see if they need adjusting
4570     * before proceeding with further jump fixups (the interleaved nature of
4571     * all the jumps makes this impossible to do without nested loops).
4572     */
4573
4574    for (i=fixupCount-1 ; i>=0 ; i--) {
4575        if (TclFixupForwardJump(envPtr, &fixupArray[i],
4576                fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
4577            int j;
4578
4579            for (j=i-1 ; j>=0 ; j--) {
4580                if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
4581                    fixupTargetArray[j] += 3;
4582                }
4583            }
4584        }
4585    }
4586    ckfree((char *) fixupArray);
4587    ckfree((char *) fixupTargetArray);
4588
4589    envPtr->currStackDepth = savedStackDepth + 1;
4590    return TCL_OK;
4591}
4592
4593/*
4594 *----------------------------------------------------------------------
4595 *
4596 * DupJumptableInfo, FreeJumptableInfo --
4597 *
4598 *      Functions to duplicate, release and print a jump-table created for use
4599 *      with the INST_JUMP_TABLE instruction.
4600 *
4601 * Results:
4602 *      DupJumptableInfo: a copy of the jump-table
4603 *      FreeJumptableInfo: none
4604 *      PrintJumptableInfo: none
4605 *
4606 * Side effects:
4607 *      DupJumptableInfo: allocates memory
4608 *      FreeJumptableInfo: releases memory
4609 *      PrintJumptableInfo: none
4610 *
4611 *----------------------------------------------------------------------
4612 */
4613
4614static ClientData
4615DupJumptableInfo(
4616    ClientData clientData)
4617{
4618    JumptableInfo *jtPtr = clientData;
4619    JumptableInfo *newJtPtr = (JumptableInfo *)
4620            ckalloc(sizeof(JumptableInfo));
4621    Tcl_HashEntry *hPtr, *newHPtr;
4622    Tcl_HashSearch search;
4623    int isNew;
4624
4625    Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
4626    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
4627    while (hPtr != NULL) {
4628        newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
4629                Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
4630        Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
4631    }
4632    return newJtPtr;
4633}
4634
4635static void
4636FreeJumptableInfo(
4637    ClientData clientData)
4638{
4639    JumptableInfo *jtPtr = clientData;
4640
4641    Tcl_DeleteHashTable(&jtPtr->hashTable);
4642    ckfree((char *) jtPtr);
4643}
4644
4645static void
4646PrintJumptableInfo(
4647    ClientData clientData,
4648    Tcl_Obj *appendObj,
4649    ByteCode *codePtr,
4650    unsigned int pcOffset)
4651{
4652    register JumptableInfo *jtPtr = clientData;
4653    Tcl_HashEntry *hPtr;
4654    Tcl_HashSearch search;
4655    const char *keyPtr;
4656    int offset, i = 0;
4657
4658    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
4659    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
4660        keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
4661        offset = PTR2INT(Tcl_GetHashValue(hPtr));
4662
4663        if (i++) {
4664            Tcl_AppendToObj(appendObj, ", ", -1);
4665            if (i%4==0) {
4666                Tcl_AppendToObj(appendObj, "\n\t\t", -1);
4667            }
4668        }
4669        Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
4670                keyPtr, pcOffset + offset);
4671    }
4672}
4673
4674/*
4675 *----------------------------------------------------------------------
4676 *
4677 * TclCompileWhileCmd --
4678 *
4679 *      Procedure called to compile the "while" command.
4680 *
4681 * Results:
4682 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
4683 *      evaluation to runtime.
4684 *
4685 * Side effects:
4686 *      Instructions are added to envPtr to execute the "while" command at
4687 *      runtime.
4688 *
4689 *----------------------------------------------------------------------
4690 */
4691
4692int
4693TclCompileWhileCmd(
4694    Tcl_Interp *interp,         /* Used for error reporting. */
4695    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
4696                                 * created by Tcl_ParseCommand. */
4697    Command *cmdPtr,            /* Points to defintion of command being
4698                                 * compiled. */
4699    CompileEnv *envPtr)         /* Holds resulting instructions. */
4700{
4701    Tcl_Token *testTokenPtr, *bodyTokenPtr;
4702    JumpFixup jumpEvalCondFixup;
4703    int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
4704    int savedStackDepth = envPtr->currStackDepth;
4705    int loopMayEnd = 1;         /* This is set to 0 if it is recognized as an
4706                                 * infinite loop. */
4707    Tcl_Obj *boolObj;
4708    DefineLineInformation;      /* TIP #280 */
4709
4710    if (parsePtr->numWords != 3) {
4711        return TCL_ERROR;
4712    }
4713
4714    /*
4715     * If the test expression requires substitutions, don't compile the while
4716     * command inline. E.g., the expression might cause the loop to never
4717     * execute or execute forever, as in "while "$x < 5" {}".
4718     *
4719     * Bail out also if the body expression requires substitutions in order to
4720     * insure correct behaviour [Bug 219166]
4721     */
4722
4723    testTokenPtr = TokenAfter(parsePtr->tokenPtr);
4724    bodyTokenPtr = TokenAfter(testTokenPtr);
4725
4726    if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
4727            || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
4728        return TCL_ERROR;
4729    }
4730
4731    /*
4732     * Find out if the condition is a constant.
4733     */
4734
4735    boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
4736    Tcl_IncrRefCount(boolObj);
4737    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
4738    TclDecrRefCount(boolObj);
4739    if (code == TCL_OK) {
4740        if (boolVal) {
4741            /*
4742             * It is an infinite loop; flag it so that we generate a more
4743             * efficient body.
4744             */
4745
4746            loopMayEnd = 0;
4747        } else {
4748            /*
4749             * This is an empty loop: "while 0 {...}" or such. Compile no
4750             * bytecodes.
4751             */
4752
4753            goto pushResult;
4754        }
4755    }
4756
4757    /*
4758     * Create a ExceptionRange record for the loop body. This is used to
4759     * implement break and continue.
4760     */
4761
4762    range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
4763
4764    /*
4765     * Jump to the evaluation of the condition. This code uses the "loop
4766     * rotation" optimisation (which eliminates one branch from the loop).
4767     * "while cond body" produces then:
4768     *       goto A
4769     *    B: body                : bodyCodeOffset
4770     *    A: cond -> result      : testCodeOffset, continueOffset
4771     *       if (result) goto B
4772     *
4773     * The infinite loop "while 1 body" produces:
4774     *    B: body                : all three offsets here
4775     *       goto B
4776     */
4777
4778    if (loopMayEnd) {
4779        TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
4780        testCodeOffset = 0;     /* Avoid compiler warning. */
4781    } else {
4782        /*
4783         * Make sure that the first command in the body is preceded by an
4784         * INST_START_CMD, and hence counted properly. [Bug 1752146]
4785         */
4786
4787        envPtr->atCmdStart = 0;
4788        testCodeOffset = CurrentOffset(envPtr);
4789    }
4790
4791    /*
4792     * Compile the loop body.
4793     */
4794
4795    envPtr->line = mapPtr->loc[eclIndex].line[2];
4796    bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
4797    CompileBody(envPtr, bodyTokenPtr, interp);
4798    ExceptionRangeEnds(envPtr, range);
4799    envPtr->currStackDepth = savedStackDepth + 1;
4800    TclEmitOpcode(INST_POP, envPtr);
4801
4802    /*
4803     * Compile the test expression then emit the conditional jump that
4804     * terminates the while. We already know it's a simple word.
4805     */
4806
4807    if (loopMayEnd) {
4808        testCodeOffset = CurrentOffset(envPtr);
4809        jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
4810        if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
4811            bodyCodeOffset += 3;
4812            testCodeOffset += 3;
4813        }
4814        envPtr->currStackDepth = savedStackDepth;
4815        envPtr->line = mapPtr->loc[eclIndex].line[1];
4816        TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
4817        envPtr->currStackDepth = savedStackDepth + 1;
4818
4819        jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
4820        if (jumpDist > 127) {
4821            TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
4822        } else {
4823            TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
4824        }
4825    } else {
4826        jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
4827        if (jumpDist > 127) {
4828            TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
4829        } else {
4830            TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
4831        }
4832    }
4833
4834    /*
4835     * Set the loop's body, continue and break offsets.
4836     */
4837
4838    envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
4839    envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
4840    ExceptionRangeTarget(envPtr, range, breakOffset);
4841
4842    /*
4843     * The while command's result is an empty string.
4844     */
4845
4846  pushResult:
4847    envPtr->currStackDepth = savedStackDepth;
4848    PushLiteral(envPtr, "", 0);
4849    return TCL_OK;
4850}
4851
4852/*
4853 *----------------------------------------------------------------------
4854 *
4855 * PushVarName --
4856 *
4857 *      Procedure used in the compiling where pushing a variable name is
4858 *      necessary (append, lappend, set).
4859 *
4860 * Results:
4861 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
4862 *      evaluation to runtime.
4863 *
4864 * Side effects:
4865 *      Instructions are added to envPtr to execute the "set" command at
4866 *      runtime.
4867 *
4868 *----------------------------------------------------------------------
4869 */
4870
4871static int
4872PushVarName(
4873    Tcl_Interp *interp,         /* Used for error reporting. */
4874    Tcl_Token *varTokenPtr,     /* Points to a variable token. */
4875    CompileEnv *envPtr,         /* Holds resulting instructions. */
4876    int flags,                  /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */
4877    int *localIndexPtr,         /* Must not be NULL. */
4878    int *simpleVarNamePtr,      /* Must not be NULL. */
4879    int *isScalarPtr,           /* Must not be NULL. */
4880    int line)                   /* Line the token starts on. */
4881{
4882    register const char *p;
4883    const char *name, *elName;
4884    register int i, n;
4885    Tcl_Token *elemTokenPtr = NULL;
4886    int nameChars, elNameChars, simpleVarName, localIndex;
4887    int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
4888
4889    /*
4890     * Decide if we can use a frame slot for the var/array name or if we need
4891     * to emit code to compute and push the name at runtime. We use a frame
4892     * slot (entry in the array of local vars) if we are compiling a procedure
4893     * body and if the name is simple text that does not include namespace
4894     * qualifiers.
4895     */
4896
4897    simpleVarName = 0;
4898    name = elName = NULL;
4899    nameChars = elNameChars = 0;
4900    localIndex = -1;
4901
4902    /*
4903     * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
4904     * curly braces surround the variable name. This really matters for array
4905     * elements to handle things like
4906     *    set {x($foo)} 5
4907     * which raises an undefined var error if we are not careful here.
4908     */
4909
4910    if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
4911            (varTokenPtr->start[0] != '{')) {
4912        /*
4913         * A simple variable name. Divide it up into "name" and "elName"
4914         * strings. If it is not a local variable, look it up at runtime.
4915         */
4916
4917        simpleVarName = 1;
4918
4919        name = varTokenPtr[1].start;
4920        nameChars = varTokenPtr[1].size;
4921        if (name[nameChars-1] == ')') {
4922            /*
4923             * last char is ')' => potential array reference.
4924             */
4925
4926            for (i=0,p=name ; i<nameChars ; i++,p++) {
4927                if (*p == '(') {
4928                    elName = p + 1;
4929                    elNameChars = nameChars - i - 2;
4930                    nameChars = i;
4931                    break;
4932                }
4933            }
4934
4935            if ((elName != NULL) && elNameChars) {
4936                /*
4937                 * An array element, the element name is a simple string:
4938                 * assemble the corresponding token.
4939                 */
4940
4941                elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
4942                        sizeof(Tcl_Token));
4943                allocedTokens = 1;
4944                elemTokenPtr->type = TCL_TOKEN_TEXT;
4945                elemTokenPtr->start = elName;
4946                elemTokenPtr->size = elNameChars;
4947                elemTokenPtr->numComponents = 0;
4948                elemTokenCount = 1;
4949            }
4950        }
4951    } else if (((n = varTokenPtr->numComponents) > 1)
4952            && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
4953            && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
4954            && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
4955
4956        /*
4957         * Check for parentheses inside first token.
4958         */
4959
4960        simpleVarName = 0;
4961        for (i = 0, p = varTokenPtr[1].start;
4962                i < varTokenPtr[1].size; i++, p++) {
4963            if (*p == '(') {
4964                simpleVarName = 1;
4965                break;
4966            }
4967        }
4968        if (simpleVarName) {
4969            int remainingChars;
4970
4971            /*
4972             * Check the last token: if it is just ')', do not count it.
4973             * Otherwise, remove the ')' and flag so that it is restored at
4974             * the end.
4975             */
4976
4977            if (varTokenPtr[n].size == 1) {
4978                --n;
4979            } else {
4980                --varTokenPtr[n].size;
4981                removedParen = n;
4982            }
4983
4984            name = varTokenPtr[1].start;
4985            nameChars = p - varTokenPtr[1].start;
4986            elName = p + 1;
4987            remainingChars = (varTokenPtr[2].start - p) - 1;
4988            elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
4989
4990            if (remainingChars) {
4991                /*
4992                 * Make a first token with the extra characters in the first
4993                 * token.
4994                 */
4995
4996                elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
4997                        n * sizeof(Tcl_Token));
4998                allocedTokens = 1;
4999                elemTokenPtr->type = TCL_TOKEN_TEXT;
5000                elemTokenPtr->start = elName;
5001                elemTokenPtr->size = remainingChars;
5002                elemTokenPtr->numComponents = 0;
5003                elemTokenCount = n;
5004
5005                /*
5006                 * Copy the remaining tokens.
5007                 */
5008
5009                memcpy(elemTokenPtr+1, varTokenPtr+2,
5010                        (n-1) * sizeof(Tcl_Token));
5011            } else {
5012                /*
5013                 * Use the already available tokens.
5014                 */
5015
5016                elemTokenPtr = &varTokenPtr[2];
5017                elemTokenCount = n - 1;
5018            }
5019        }
5020    }
5021
5022    if (simpleVarName) {
5023        /*
5024         * See whether name has any namespace separators (::'s).
5025         */
5026
5027        int hasNsQualifiers = 0;
5028        for (i = 0, p = name;  i < nameChars;  i++, p++) {
5029            if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
5030                hasNsQualifiers = 1;
5031                break;
5032            }
5033        }
5034
5035        /*
5036         * Look up the var name's index in the array of local vars in the proc
5037         * frame. If retrieving the var's value and it doesn't already exist,
5038         * push its name and look it up at runtime.
5039         */
5040
5041        if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
5042            localIndex = TclFindCompiledLocal(name, nameChars,
5043                    /*create*/ flags & TCL_CREATE_VAR,
5044                    envPtr->procPtr);
5045            if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
5046                /*
5047                 * We'll push the name.
5048                 */
5049
5050                localIndex = -1;
5051            }
5052        }
5053        if (localIndex < 0) {
5054            PushLiteral(envPtr, name, nameChars);
5055        }
5056
5057        /*
5058         * Compile the element script, if any.
5059         */
5060
5061        if (elName != NULL) {
5062            if (elNameChars) {
5063                envPtr->line = line;
5064                TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
5065            } else {
5066                PushLiteral(envPtr, "", 0);
5067            }
5068        }
5069    } else {
5070        /*
5071         * The var name isn't simple: compile and push it.
5072         */
5073
5074        envPtr->line = line;
5075        CompileTokens(envPtr, varTokenPtr, interp);
5076    }
5077
5078    if (removedParen) {
5079        ++varTokenPtr[removedParen].size;
5080    }
5081    if (allocedTokens) {
5082        TclStackFree(interp, elemTokenPtr);
5083    }
5084    *localIndexPtr = localIndex;
5085    *simpleVarNamePtr = simpleVarName;
5086    *isScalarPtr = (elName == NULL);
5087    return TCL_OK;
5088}
5089
5090/*
5091 *----------------------------------------------------------------------
5092 *
5093 * CompileUnaryOpCmd --
5094 *
5095 *      Utility routine to compile the unary operator commands.
5096 *
5097 * Results:
5098 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5099 *      evaluation to runtime.
5100 *
5101 * Side effects:
5102 *      Instructions are added to envPtr to execute the compiled command at
5103 *      runtime.
5104 *
5105 *----------------------------------------------------------------------
5106 */
5107
5108static int
5109CompileUnaryOpCmd(
5110    Tcl_Interp *interp,
5111    Tcl_Parse *parsePtr,
5112    int instruction,
5113    CompileEnv *envPtr)
5114{
5115    Tcl_Token *tokenPtr;
5116    DefineLineInformation;      /* TIP #280 */
5117
5118    if (parsePtr->numWords != 2) {
5119        return TCL_ERROR;
5120    }
5121    tokenPtr = TokenAfter(parsePtr->tokenPtr);
5122    CompileWord(envPtr, tokenPtr, interp, 1);
5123    TclEmitOpcode(instruction, envPtr);
5124    return TCL_OK;
5125}
5126
5127/*
5128 *----------------------------------------------------------------------
5129 *
5130 * CompileAssociativeBinaryOpCmd --
5131 *
5132 *      Utility routine to compile the binary operator commands that accept an
5133 *      arbitrary number of arguments, and that are associative operations.
5134 *      Because of the associativity, we may combine operations from right to
5135 *      left, saving us any effort of re-ordering the arguments on the stack
5136 *      after substitutions are completed.
5137 *
5138 * Results:
5139 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5140 *      evaluation to runtime.
5141 *
5142 * Side effects:
5143 *      Instructions are added to envPtr to execute the compiled command at
5144 *      runtime.
5145 *
5146 *----------------------------------------------------------------------
5147 */
5148
5149static int
5150CompileAssociativeBinaryOpCmd(
5151    Tcl_Interp *interp,
5152    Tcl_Parse *parsePtr,
5153    const char *identity,
5154    int instruction,
5155    CompileEnv *envPtr)
5156{
5157    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
5158    DefineLineInformation;      /* TIP #280 */
5159    int words;
5160
5161    for (words=1 ; words<parsePtr->numWords ; words++) {
5162        tokenPtr = TokenAfter(tokenPtr);
5163        CompileWord(envPtr, tokenPtr, interp, words);
5164    }
5165    if (parsePtr->numWords <= 2) {
5166        PushLiteral(envPtr, identity, -1);
5167        words++;
5168    }
5169    if (words > 3) {
5170        /*
5171         * Reverse order of arguments to get precise agreement with
5172         * [expr] in calcuations, including roundoff errors.
5173         */
5174        TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
5175    }
5176    while (--words > 1) {
5177        TclEmitOpcode(instruction, envPtr);
5178    }
5179    return TCL_OK;
5180}
5181
5182/*
5183 *----------------------------------------------------------------------
5184 *
5185 * CompileStrictlyBinaryOpCmd --
5186 *
5187 *      Utility routine to compile the binary operator commands, that strictly
5188 *      accept exactly two arguments.
5189 *
5190 * Results:
5191 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5192 *      evaluation to runtime.
5193 *
5194 * Side effects:
5195 *      Instructions are added to envPtr to execute the compiled command at
5196 *      runtime.
5197 *
5198 *----------------------------------------------------------------------
5199 */
5200
5201static int
5202CompileStrictlyBinaryOpCmd(
5203    Tcl_Interp *interp,
5204    Tcl_Parse *parsePtr,
5205    int instruction,
5206    CompileEnv *envPtr)
5207{
5208    if (parsePtr->numWords != 3) {
5209        return TCL_ERROR;
5210    }
5211    return CompileAssociativeBinaryOpCmd(interp, parsePtr,
5212            NULL, instruction, envPtr);
5213}
5214
5215/*
5216 *----------------------------------------------------------------------
5217 *
5218 * CompileComparisonOpCmd --
5219 *
5220 *      Utility routine to compile the n-ary comparison operator commands.
5221 *
5222 * Results:
5223 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5224 *      evaluation to runtime.
5225 *
5226 * Side effects:
5227 *      Instructions are added to envPtr to execute the compiled command at
5228 *      runtime.
5229 *
5230 *----------------------------------------------------------------------
5231 */
5232
5233static int
5234CompileComparisonOpCmd(
5235    Tcl_Interp *interp,
5236    Tcl_Parse *parsePtr,
5237    int instruction,
5238    CompileEnv *envPtr)
5239{
5240    Tcl_Token *tokenPtr;
5241    DefineLineInformation;      /* TIP #280 */
5242
5243    if (parsePtr->numWords < 3) {
5244        PushLiteral(envPtr, "1", 1);
5245    } else if (parsePtr->numWords == 3) {
5246        tokenPtr = TokenAfter(parsePtr->tokenPtr);
5247        CompileWord(envPtr, tokenPtr, interp, 1);
5248        tokenPtr = TokenAfter(tokenPtr);
5249        CompileWord(envPtr, tokenPtr, interp, 2);
5250        TclEmitOpcode(instruction, envPtr);
5251    } else if (envPtr->procPtr == NULL) {
5252        /*
5253         * No local variable space!
5254         */
5255
5256        return TCL_ERROR;
5257    } else {
5258        int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr);
5259        int words;
5260
5261        tokenPtr = TokenAfter(parsePtr->tokenPtr);
5262        CompileWord(envPtr, tokenPtr, interp, 1);
5263        tokenPtr = TokenAfter(tokenPtr);
5264        CompileWord(envPtr, tokenPtr, interp, 2);
5265        if (tmpIndex <= 255) {
5266            TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
5267        } else {
5268            TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
5269        }
5270        TclEmitOpcode(instruction, envPtr);
5271        for (words=3 ; words<parsePtr->numWords ;) {
5272            if (tmpIndex <= 255) {
5273                TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
5274            } else {
5275                TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
5276            }
5277            tokenPtr = TokenAfter(tokenPtr);
5278            CompileWord(envPtr, tokenPtr, interp, words);
5279            if (++words < parsePtr->numWords) {
5280                if (tmpIndex <= 255) {
5281                    TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
5282                } else {
5283                    TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
5284                }
5285            }
5286            TclEmitOpcode(instruction, envPtr);
5287        }
5288        for (; words>3 ; words--) {
5289            TclEmitOpcode(INST_BITAND, envPtr);
5290        }
5291
5292        /*
5293         * Drop the value from the temp variable; retaining that reference
5294         * might be expensive elsewhere.
5295         */
5296
5297        PushLiteral(envPtr, "", 0);
5298        if (tmpIndex <= 255) {
5299            TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
5300        } else {
5301            TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
5302        }
5303        TclEmitOpcode(INST_POP, envPtr);
5304    }
5305    return TCL_OK;
5306}
5307
5308/*
5309 *----------------------------------------------------------------------
5310 *
5311 * TclCompile*OpCmd --
5312 *
5313 *      Procedures called to compile the corresponding "::tcl::mathop::*"
5314 *      commands. These are all wrappers around the utility operator command
5315 *      compiler functions, except for the compilers for subtraction and
5316 *      division, which are special.
5317 *
5318 * Results:
5319 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5320 *      evaluation to runtime.
5321 *
5322 * Side effects:
5323 *      Instructions are added to envPtr to execute the compiled command at
5324 *      runtime.
5325 *
5326 *----------------------------------------------------------------------
5327 */
5328
5329int
5330TclCompileInvertOpCmd(
5331    Tcl_Interp *interp,
5332    Tcl_Parse *parsePtr,
5333    Command *cmdPtr,            /* Points to defintion of command being
5334                                 * compiled. */
5335    CompileEnv *envPtr)
5336{
5337    return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
5338}
5339
5340int
5341TclCompileNotOpCmd(
5342    Tcl_Interp *interp,
5343    Tcl_Parse *parsePtr,
5344    Command *cmdPtr,            /* Points to defintion of command being
5345                                 * compiled. */
5346    CompileEnv *envPtr)
5347{
5348    return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
5349}
5350
5351int
5352TclCompileAddOpCmd(
5353    Tcl_Interp *interp,
5354    Tcl_Parse *parsePtr,
5355    Command *cmdPtr,            /* Points to defintion of command being
5356                                 * compiled. */
5357    CompileEnv *envPtr)
5358{
5359    return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
5360            envPtr);
5361}
5362
5363int
5364TclCompileMulOpCmd(
5365    Tcl_Interp *interp,
5366    Tcl_Parse *parsePtr,
5367    Command *cmdPtr,            /* Points to defintion of command being
5368                                 * compiled. */
5369    CompileEnv *envPtr)
5370{
5371    return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
5372            envPtr);
5373}
5374
5375int
5376TclCompileAndOpCmd(
5377    Tcl_Interp *interp,
5378    Tcl_Parse *parsePtr,
5379    Command *cmdPtr,            /* Points to defintion of command being
5380                                 * compiled. */
5381    CompileEnv *envPtr)
5382{
5383    return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
5384            envPtr);
5385}
5386
5387int
5388TclCompileOrOpCmd(
5389    Tcl_Interp *interp,
5390    Tcl_Parse *parsePtr,
5391    Command *cmdPtr,            /* Points to defintion of command being
5392                                 * compiled. */
5393    CompileEnv *envPtr)
5394{
5395    return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
5396            envPtr);
5397}
5398
5399int
5400TclCompileXorOpCmd(
5401    Tcl_Interp *interp,
5402    Tcl_Parse *parsePtr,
5403    Command *cmdPtr,            /* Points to defintion of command being
5404                                 * compiled. */
5405    CompileEnv *envPtr)
5406{
5407    return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
5408            envPtr);
5409}
5410
5411int
5412TclCompilePowOpCmd(
5413    Tcl_Interp *interp,
5414    Tcl_Parse *parsePtr,
5415    Command *cmdPtr,            /* Points to defintion of command being
5416                                 * compiled. */
5417    CompileEnv *envPtr)
5418{
5419    /*
5420     * This one has its own implementation because the ** operator is
5421     * the only one with right associativity.
5422     */
5423    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
5424    DefineLineInformation;      /* TIP #280 */
5425    int words;
5426
5427    for (words=1 ; words<parsePtr->numWords ; words++) {
5428        tokenPtr = TokenAfter(tokenPtr);
5429        CompileWord(envPtr, tokenPtr, interp, words);
5430    }
5431    if (parsePtr->numWords <= 2) {
5432        PushLiteral(envPtr, "1", 1);
5433        words++;
5434    }
5435    while (--words > 1) {
5436        TclEmitOpcode(INST_EXPON, envPtr);
5437    }
5438    return TCL_OK;
5439}
5440
5441int
5442TclCompileLshiftOpCmd(
5443    Tcl_Interp *interp,
5444    Tcl_Parse *parsePtr,
5445    Command *cmdPtr,            /* Points to defintion of command being
5446                                 * compiled. */
5447    CompileEnv *envPtr)
5448{
5449    return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
5450}
5451
5452int
5453TclCompileRshiftOpCmd(
5454    Tcl_Interp *interp,
5455    Tcl_Parse *parsePtr,
5456    Command *cmdPtr,            /* Points to defintion of command being
5457                                 * compiled. */
5458    CompileEnv *envPtr)
5459{
5460    return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
5461}
5462
5463int
5464TclCompileModOpCmd(
5465    Tcl_Interp *interp,
5466    Tcl_Parse *parsePtr,
5467    Command *cmdPtr,            /* Points to defintion of command being
5468                                 * compiled. */
5469    CompileEnv *envPtr)
5470{
5471    return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
5472}
5473
5474int
5475TclCompileNeqOpCmd(
5476    Tcl_Interp *interp,
5477    Tcl_Parse *parsePtr,
5478    Command *cmdPtr,            /* Points to defintion of command being
5479                                 * compiled. */
5480    CompileEnv *envPtr)
5481{
5482    return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
5483}
5484
5485int
5486TclCompileStrneqOpCmd(
5487    Tcl_Interp *interp,
5488    Tcl_Parse *parsePtr,
5489    Command *cmdPtr,            /* Points to defintion of command being
5490                                 * compiled. */
5491    CompileEnv *envPtr)
5492{
5493    return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
5494}
5495
5496int
5497TclCompileInOpCmd(
5498    Tcl_Interp *interp,
5499    Tcl_Parse *parsePtr,
5500    Command *cmdPtr,            /* Points to defintion of command being
5501                                 * compiled. */
5502    CompileEnv *envPtr)
5503{
5504    return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
5505}
5506
5507int
5508TclCompileNiOpCmd(
5509    Tcl_Interp *interp,
5510    Tcl_Parse *parsePtr,
5511    Command *cmdPtr,            /* Points to defintion of command being
5512                                 * compiled. */
5513    CompileEnv *envPtr)
5514{
5515    return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
5516            envPtr);
5517}
5518
5519int
5520TclCompileLessOpCmd(
5521    Tcl_Interp *interp,
5522    Tcl_Parse *parsePtr,
5523    Command *cmdPtr,            /* Points to defintion of command being
5524                                 * compiled. */
5525    CompileEnv *envPtr)
5526{
5527    return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
5528}
5529
5530int
5531TclCompileLeqOpCmd(
5532    Tcl_Interp *interp,
5533    Tcl_Parse *parsePtr,
5534    Command *cmdPtr,            /* Points to defintion of command being
5535                                 * compiled. */
5536    CompileEnv *envPtr)
5537{
5538    return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
5539}
5540
5541int
5542TclCompileGreaterOpCmd(
5543    Tcl_Interp *interp,
5544    Tcl_Parse *parsePtr,
5545    Command *cmdPtr,            /* Points to defintion of command being
5546                                 * compiled. */
5547    CompileEnv *envPtr)
5548{
5549    return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
5550}
5551
5552int
5553TclCompileGeqOpCmd(
5554    Tcl_Interp *interp,
5555    Tcl_Parse *parsePtr,
5556    Command *cmdPtr,            /* Points to defintion of command being
5557                                 * compiled. */
5558    CompileEnv *envPtr)
5559{
5560    return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
5561}
5562
5563int
5564TclCompileEqOpCmd(
5565    Tcl_Interp *interp,
5566    Tcl_Parse *parsePtr,
5567    Command *cmdPtr,            /* Points to defintion of command being
5568                                 * compiled. */
5569    CompileEnv *envPtr)
5570{
5571    return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
5572}
5573
5574int
5575TclCompileStreqOpCmd(
5576    Tcl_Interp *interp,
5577    Tcl_Parse *parsePtr,
5578    Command *cmdPtr,            /* Points to defintion of command being
5579                                 * compiled. */
5580    CompileEnv *envPtr)
5581{
5582    return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
5583}
5584
5585int
5586TclCompileMinusOpCmd(
5587    Tcl_Interp *interp,
5588    Tcl_Parse *parsePtr,
5589    Command *cmdPtr,            /* Points to defintion of command being
5590                                 * compiled. */
5591    CompileEnv *envPtr)
5592{
5593    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
5594    DefineLineInformation;      /* TIP #280 */
5595    int words;
5596
5597    if (parsePtr->numWords == 1) {
5598        /* Fallback to direct eval to report syntax error */
5599        return TCL_ERROR;
5600    }
5601    for (words=1 ; words<parsePtr->numWords ; words++) {
5602        tokenPtr = TokenAfter(tokenPtr);
5603        CompileWord(envPtr, tokenPtr, interp, words);
5604    }
5605    if (words == 2) {
5606        TclEmitOpcode(INST_UMINUS, envPtr);
5607        return TCL_OK;
5608    }
5609    if (words == 3) {
5610        TclEmitOpcode(INST_SUB, envPtr);
5611        return TCL_OK;
5612    }
5613    /*
5614     * Reverse order of arguments to get precise agreement with
5615     * [expr] in calcuations, including roundoff errors.
5616     */
5617    TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
5618    while (--words > 1) {
5619        TclEmitInstInt4(INST_REVERSE, 2, envPtr);
5620        TclEmitOpcode(INST_SUB, envPtr);
5621    }
5622    return TCL_OK;
5623}
5624
5625int
5626TclCompileDivOpCmd(
5627    Tcl_Interp *interp,
5628    Tcl_Parse *parsePtr,
5629    Command *cmdPtr,            /* Points to defintion of command being
5630                                 * compiled. */
5631    CompileEnv *envPtr)
5632{
5633    Tcl_Token *tokenPtr = parsePtr->tokenPtr;
5634    DefineLineInformation;      /* TIP #280 */
5635    int words;
5636
5637    if (parsePtr->numWords == 1) {
5638        /* Fallback to direct eval to report syntax error */
5639        return TCL_ERROR;
5640    }
5641    if (parsePtr->numWords == 2) {
5642        PushLiteral(envPtr, "1.0", 3);
5643    }
5644    for (words=1 ; words<parsePtr->numWords ; words++) {
5645        tokenPtr = TokenAfter(tokenPtr);
5646        CompileWord(envPtr, tokenPtr, interp, words);
5647    }
5648    if (words <= 3) {
5649        TclEmitOpcode(INST_DIV, envPtr);
5650        return TCL_OK;
5651    }
5652    /*
5653     * Reverse order of arguments to get precise agreement with
5654     * [expr] in calcuations, including roundoff errors.
5655     */
5656    TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
5657    while (--words > 1) {
5658        TclEmitInstInt4(INST_REVERSE, 2, envPtr);
5659        TclEmitOpcode(INST_DIV, envPtr);
5660    }
5661    return TCL_OK;
5662}
5663
5664/*
5665 *----------------------------------------------------------------------
5666 *
5667 * IndexTailVarIfKnown --
5668 *
5669 *      Procedure used in compiling [global] and [variable] commands. It
5670 *      inspects the variable name described by varTokenPtr and, if the tail
5671 *      is known at compile time, defines a corresponding local variable.
5672 *
5673 * Results:
5674 *      Returns the variable's index in the table of compiled locals if the
5675 *      tail is known at compile time, or -1 otherwise.
5676 *
5677 * Side effects:
5678 *      None.
5679 *
5680 *----------------------------------------------------------------------
5681 */
5682
5683static int
5684IndexTailVarIfKnown(
5685    Tcl_Interp *interp,
5686    Tcl_Token *varTokenPtr,     /* Token representing the variable name */
5687    CompileEnv *envPtr)         /* Holds resulting instructions. */
5688{
5689    Tcl_Obj *tailPtr;
5690    const char *tailName, *p;
5691    int len, n = varTokenPtr->numComponents;
5692    Tcl_Token *lastTokenPtr;
5693    int full, localIndex;
5694
5695    /*
5696     * Determine if the tail is (a) known at compile time, and (b) not an
5697     * array element. Should any of these fail, return an error so that
5698     * the non-compiled command will be called at runtime.
5699     * In order for the tail to be known at compile time, the last token
5700     * in the word has to be constant and contain "::" if it is not the
5701     * only one.
5702     */
5703
5704    if (envPtr->procPtr == NULL) {
5705        return -1;
5706    }
5707
5708    TclNewObj(tailPtr);
5709    if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
5710        full = 1;
5711        lastTokenPtr = varTokenPtr;
5712    } else {
5713        full = 0;
5714        lastTokenPtr = varTokenPtr + n;
5715        if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
5716            Tcl_DecrRefCount(tailPtr);
5717            return -1;
5718        }
5719    }
5720
5721    tailName = TclGetStringFromObj(tailPtr, &len);
5722
5723    if (len) {
5724        if (*(tailName+len-1) == ')') {
5725            /*
5726             * Possible array: bail out
5727             */
5728
5729            Tcl_DecrRefCount(tailPtr);
5730            return -1;
5731        }
5732
5733        /*
5734         * Get the tail: immediately after the last '::'
5735         */
5736
5737        for(p = tailName + len -1; p > tailName; p--) {
5738            if ((*p == ':') && (*(p-1) == ':')) {
5739                p++;
5740                break;
5741            }
5742        }
5743        if (!full && (p == tailName)) {
5744            /*
5745             * No :: in the last component
5746             */
5747            Tcl_DecrRefCount(tailPtr);
5748            return -1;
5749        }
5750        len -= p - tailName;
5751        tailName = p;
5752    }
5753
5754    localIndex = TclFindCompiledLocal(tailName, len,
5755            /*create*/ TCL_CREATE_VAR,
5756            envPtr->procPtr);
5757    Tcl_DecrRefCount(tailPtr);
5758    return localIndex;
5759}
5760
5761/*
5762 *----------------------------------------------------------------------
5763 *
5764 * TclCompileUpvarCmd --
5765 *
5766 *      Procedure called to compile the "upvar" command.
5767 *
5768 * Results:
5769 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5770 *      evaluation to runtime.
5771 *
5772 * Side effects:
5773 *      Instructions are added to envPtr to execute the "upvar" command at
5774 *      runtime.
5775 *
5776 *----------------------------------------------------------------------
5777 */
5778
5779int
5780TclCompileUpvarCmd(
5781    Tcl_Interp *interp,         /* Used for error reporting. */
5782    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
5783                                 * created by Tcl_ParseCommand. */
5784    Command *cmdPtr,            /* Points to defintion of command being
5785                                 * compiled. */
5786    CompileEnv *envPtr)         /* Holds resulting instructions. */
5787{
5788    Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
5789    int simpleVarName, isScalar, localIndex, numWords, i;
5790    DefineLineInformation;      /* TIP #280 */
5791    Tcl_Obj *objPtr = Tcl_NewObj();
5792
5793    if (envPtr->procPtr == NULL) {
5794        Tcl_DecrRefCount(objPtr);
5795        return TCL_ERROR;
5796    }
5797
5798    numWords = parsePtr->numWords;
5799    if (numWords < 3) {
5800        Tcl_DecrRefCount(objPtr);
5801        return TCL_ERROR;
5802    }
5803
5804    /*
5805     * Push the frame index if it is known at compile time
5806     */
5807
5808    tokenPtr = TokenAfter(parsePtr->tokenPtr);
5809    if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
5810        CallFrame *framePtr;
5811        Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
5812
5813        /*
5814         * Attempt to convert to a level reference. Note that TclObjGetFrame
5815         * only changes the obj type when a conversion was successful.
5816         */
5817
5818        TclObjGetFrame(interp, objPtr, &framePtr);
5819        newTypePtr = objPtr->typePtr;
5820        Tcl_DecrRefCount(objPtr);
5821
5822        if (newTypePtr != typePtr) {
5823            if(numWords%2) {
5824                return TCL_ERROR;
5825            }
5826            CompileWord(envPtr, tokenPtr, interp, 1);
5827            otherTokenPtr = TokenAfter(tokenPtr);
5828            i = 4;
5829        } else {
5830            if(!(numWords%2)) {
5831                return TCL_ERROR;
5832            }
5833            PushLiteral(envPtr, "1", 1);
5834            otherTokenPtr = tokenPtr;
5835            i = 3;
5836        }
5837    } else {
5838        Tcl_DecrRefCount(objPtr);
5839        return TCL_ERROR;
5840    }
5841
5842    /*
5843     * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
5844     * local variable, return an error so that the non-compiled command will
5845     * be called at runtime.
5846     */
5847
5848    for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
5849        localTokenPtr = TokenAfter(otherTokenPtr);
5850
5851        CompileWord(envPtr, otherTokenPtr, interp, 1);
5852        PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR,
5853                &localIndex, &simpleVarName, &isScalar,
5854                mapPtr->loc[eclIndex].line[1]);
5855
5856        if((localIndex < 0) || !isScalar) {
5857            return TCL_ERROR;
5858        }
5859        TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
5860    }
5861
5862    /*
5863     * Pop the frame index, and set the result to empty
5864     */
5865
5866    TclEmitOpcode(INST_POP, envPtr);
5867    PushLiteral(envPtr, "", 0);
5868    return TCL_OK;
5869}
5870
5871/*
5872 *----------------------------------------------------------------------
5873 *
5874 * TclCompileNamespaceCmd --
5875 *
5876 *      Procedure called to compile the "namespace" command; currently, only
5877 *      the subcommand "namespace upvar" is compiled to bytecodes.
5878 *
5879 * Results:
5880 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5881 *      evaluation to runtime.
5882 *
5883 * Side effects:
5884 *      Instructions are added to envPtr to execute the "namespace upvar"
5885 *      command at runtime.
5886 *
5887 *----------------------------------------------------------------------
5888 */
5889
5890int
5891TclCompileNamespaceCmd(
5892    Tcl_Interp *interp,         /* Used for error reporting. */
5893    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
5894                                 * created by Tcl_ParseCommand. */
5895    Command *cmdPtr,            /* Points to defintion of command being
5896                                 * compiled. */
5897    CompileEnv *envPtr)         /* Holds resulting instructions. */
5898{
5899    Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
5900    int simpleVarName, isScalar, localIndex, numWords, i;
5901    DefineLineInformation;      /* TIP #280 */
5902
5903    if (envPtr->procPtr == NULL) {
5904        return TCL_ERROR;
5905    }
5906
5907    /*
5908     * Only compile [namespace upvar ...]: needs an odd number of args, >=5
5909     */
5910
5911    numWords = parsePtr->numWords;
5912    if (!(numWords%2) || (numWords < 5)) {
5913        return TCL_ERROR;
5914    }
5915
5916    /*
5917     * Check if the second argument is "upvar"
5918     */
5919
5920    tokenPtr = TokenAfter(parsePtr->tokenPtr);
5921    if ((tokenPtr->size != 5)  /* 5 == strlen("upvar") */
5922            || strncmp(tokenPtr->start, "upvar", 5)) {
5923        return TCL_ERROR;
5924    }
5925
5926    /*
5927     * Push the namespace
5928     */
5929
5930    tokenPtr = TokenAfter(tokenPtr);
5931    CompileWord(envPtr, tokenPtr, interp, 1);
5932
5933    /*
5934     * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
5935     * local variable, return an error so that the non-compiled command will
5936     * be called at runtime.
5937     */
5938
5939    localTokenPtr = tokenPtr;
5940    for(i=4; i<=numWords; i+=2) {
5941        otherTokenPtr = TokenAfter(localTokenPtr);
5942        localTokenPtr = TokenAfter(otherTokenPtr);
5943
5944        CompileWord(envPtr, otherTokenPtr, interp, 1);
5945        PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR,
5946                &localIndex, &simpleVarName, &isScalar,
5947                mapPtr->loc[eclIndex].line[1]);
5948
5949        if((localIndex < 0) || !isScalar) {
5950            return TCL_ERROR;
5951        }
5952        TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
5953    }
5954
5955    /*
5956     * Pop the namespace, and set the result to empty
5957     */
5958
5959    TclEmitOpcode(INST_POP, envPtr);
5960    PushLiteral(envPtr, "", 0);
5961    return TCL_OK;
5962}
5963
5964/*
5965 *----------------------------------------------------------------------
5966 *
5967 * TclCompileGlobalCmd --
5968 *
5969 *      Procedure called to compile the "global" command.
5970 *
5971 * Results:
5972 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
5973 *      evaluation to runtime.
5974 *
5975 * Side effects:
5976 *      Instructions are added to envPtr to execute the "global" command at
5977 *      runtime.
5978 *
5979 *----------------------------------------------------------------------
5980 */
5981
5982int
5983TclCompileGlobalCmd(
5984    Tcl_Interp *interp,         /* Used for error reporting. */
5985    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
5986                                 * created by Tcl_ParseCommand. */
5987    Command *cmdPtr,            /* Points to defintion of command being
5988                                 * compiled. */
5989    CompileEnv *envPtr)         /* Holds resulting instructions. */
5990{
5991    Tcl_Token *varTokenPtr;
5992    int localIndex, numWords, i;
5993    DefineLineInformation;      /* TIP #280 */
5994
5995    numWords = parsePtr->numWords;
5996    if (numWords < 2) {
5997        return TCL_ERROR;
5998    }
5999
6000    /*
6001     * 'global' has no effect outside of proc bodies; handle that at runtime
6002     */
6003
6004    if (envPtr->procPtr == NULL) {
6005        return TCL_ERROR;
6006    }
6007
6008    /*
6009     * Push the namespace
6010     */
6011
6012    PushLiteral(envPtr, "::", 2);
6013
6014    /*
6015     * Loop over the variables.
6016     */
6017
6018    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
6019    for(i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
6020        localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
6021
6022        if(localIndex < 0) {
6023            return TCL_ERROR;
6024        }
6025
6026        CompileWord(envPtr, varTokenPtr, interp, 1);
6027        TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
6028    }
6029
6030    /*
6031     * Pop the namespace, and set the result to empty
6032     */
6033
6034    TclEmitOpcode(INST_POP, envPtr);
6035    PushLiteral(envPtr, "", 0);
6036    return TCL_OK;
6037}
6038
6039/*
6040 *----------------------------------------------------------------------
6041 *
6042 * TclCompileVariableCmd --
6043 *
6044 *      Procedure called to compile the "variable" command.
6045 *
6046 * Results:
6047 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
6048 *      evaluation to runtime.
6049 *
6050 * Side effects:
6051 *      Instructions are added to envPtr to execute the "variable" command at
6052 *      runtime.
6053 *
6054 *----------------------------------------------------------------------
6055 */
6056
6057int
6058TclCompileVariableCmd(
6059    Tcl_Interp *interp,         /* Used for error reporting. */
6060    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
6061                                 * created by Tcl_ParseCommand. */
6062    Command *cmdPtr,            /* Points to defintion of command being
6063                                 * compiled. */
6064    CompileEnv *envPtr)         /* Holds resulting instructions. */
6065{
6066    Tcl_Token *varTokenPtr, *valueTokenPtr;
6067    int localIndex, numWords, i;
6068    DefineLineInformation;      /* TIP #280 */
6069
6070    numWords = parsePtr->numWords;
6071    if (numWords < 2) {
6072        return TCL_ERROR;
6073    }
6074
6075    /*
6076     * Bail out if not compiling a proc body
6077     */
6078
6079    if (envPtr->procPtr == NULL) {
6080        return TCL_ERROR;
6081    }
6082
6083    /*
6084     * Loop over the (var, value) pairs.
6085     */
6086
6087    valueTokenPtr = parsePtr->tokenPtr;
6088    for(i=2; i<=numWords; i+=2) {
6089        varTokenPtr = TokenAfter(valueTokenPtr);
6090        valueTokenPtr = TokenAfter(varTokenPtr);
6091
6092        localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
6093
6094        if(localIndex < 0) {
6095            return TCL_ERROR;
6096        }
6097
6098        CompileWord(envPtr, varTokenPtr, interp, 1);
6099        TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
6100
6101        if (i != numWords) {
6102            /*
6103             * A value has been given: set the variable, pop the value
6104             */
6105
6106            CompileWord(envPtr, valueTokenPtr, interp, 1);
6107            TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
6108            TclEmitOpcode(INST_POP, envPtr);
6109        }
6110    }
6111
6112    /*
6113     * Set the result to empty
6114     */
6115
6116    PushLiteral(envPtr, "", 0);
6117    return TCL_OK;
6118}
6119
6120/*
6121 *----------------------------------------------------------------------
6122 *
6123 * TclCompileEnsemble --
6124 *
6125 *      Procedure called to compile an ensemble command. Note that most
6126 *      ensembles are not compiled, since modifying a compiled ensemble causes
6127 *      a invalidation of all existing bytecode (expensive!) which is not
6128 *      normally warranted.
6129 *
6130 * Results:
6131 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
6132 *      evaluation to runtime.
6133 *
6134 * Side effects:
6135 *      Instructions are added to envPtr to execute the subcommands of the
6136 *      ensemble at runtime if a compile-time mapping is possible.
6137 *
6138 *----------------------------------------------------------------------
6139 */
6140
6141int
6142TclCompileEnsemble(
6143    Tcl_Interp *interp,         /* Used for error reporting. */
6144    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
6145                                 * created by Tcl_ParseCommand. */
6146    Command *cmdPtr,            /* Points to defintion of command being
6147                                 * compiled. */
6148    CompileEnv *envPtr)         /* Holds resulting instructions. */
6149{
6150    Tcl_Token *tokenPtr;
6151    Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
6152    Tcl_Command ensemble = (Tcl_Command) cmdPtr;
6153    Tcl_Parse synthetic;
6154    int len, numBytes, result, flags = 0, i;
6155    const char *word;
6156
6157    if (parsePtr->numWords < 2) {
6158        return TCL_ERROR;
6159    }
6160
6161    tokenPtr = TokenAfter(parsePtr->tokenPtr);
6162    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
6163        /*
6164         * Too hard.
6165         */
6166
6167        return TCL_ERROR;
6168    }
6169
6170    word = tokenPtr[1].start;
6171    numBytes = tokenPtr[1].size;
6172
6173    /*
6174     * There's a sporting chance we'll be able to compile this. But now we
6175     * must check properly. To do that, check that we're compiling an ensemble
6176     * that has a compilable command as its appropriate subcommand.
6177     */
6178
6179    if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
6180            || mapObj == NULL) {
6181        /*
6182         * Either not an ensemble or a mapping isn't installed. Crud. Too hard
6183         * to proceed.
6184         */
6185
6186        return TCL_ERROR;
6187    }
6188
6189    /*
6190     * Next, get the flags. We need them on several code paths.
6191     */
6192
6193    (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
6194
6195    /*
6196     * Check to see if there's also a subcommand list; must check to see if
6197     * the subcommand we are calling is in that list if it exists, since that
6198     * list filters the entries in the map.
6199     */
6200
6201    (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
6202    if (listObj != NULL) {
6203        int sclen;
6204        const char *str;
6205        Tcl_Obj *matchObj = NULL;
6206
6207        if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
6208            return TCL_ERROR;
6209        }
6210        for (i=0 ; i<len ; i++) {
6211            str = Tcl_GetStringFromObj(elems[i], &sclen);
6212            if (sclen==numBytes && !memcmp(word, str, (unsigned) numBytes)) {
6213                /*
6214                 * Exact match! Excellent!
6215                 */
6216
6217                result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
6218                if (result != TCL_OK || targetCmdObj == NULL) {
6219                    return TCL_ERROR;
6220                }
6221                goto doneMapLookup;
6222            }
6223
6224            /*
6225             * Check to see if we've got a prefix match. A single prefix match
6226             * is fine, and allows us to refine our dictionary lookup, but
6227             * multiple prefix matches is a Bad Thing and will prevent us from
6228             * making progress. Note that we cannot do the lookup immediately
6229             * in the prefix case; might be another entry later in the list
6230             * that causes things to fail.
6231             */
6232
6233            if ((flags & TCL_ENSEMBLE_PREFIX)
6234                    && strncmp(word, str, (unsigned) numBytes) == 0) {
6235                if (matchObj != NULL) {
6236                    return TCL_ERROR;
6237                }
6238                matchObj = elems[i];
6239            }
6240        }
6241        if (matchObj != NULL) {
6242            result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
6243            if (result != TCL_OK || targetCmdObj == NULL) {
6244                return TCL_ERROR;
6245            }
6246            goto doneMapLookup;
6247        }
6248        return TCL_ERROR;
6249    } else {
6250        /*
6251         * No map, so check the dictionary directly.
6252         */
6253
6254        TclNewStringObj(subcmdObj, word, numBytes);
6255        result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
6256        TclDecrRefCount(subcmdObj);
6257        if (result == TCL_OK && targetCmdObj != NULL) {
6258            /*
6259             * Got it. Skip the fiddling around with prefixes.
6260             */
6261
6262            goto doneMapLookup;
6263        }
6264
6265        /*
6266         * We've not literally got a valid subcommand. But maybe we have a
6267         * prefix. Check if prefix matches are allowed.
6268         */
6269
6270        if (flags & TCL_ENSEMBLE_PREFIX) {
6271            Tcl_DictSearch s;
6272            int done, matched;
6273            Tcl_Obj *tmpObj;
6274
6275            /*
6276             * Iterate over the keys in the dictionary, checking to see if
6277             * we're a prefix.
6278             */
6279
6280            Tcl_DictObjFirst(NULL,mapObj,&s,&subcmdObj,&tmpObj,&done);
6281            matched = 0;
6282            while (!done) {
6283                if (strncmp(TclGetString(subcmdObj), word,
6284                        (unsigned) numBytes) == 0) {
6285                    if (matched++) {
6286                        /*
6287                         * Must have matched twice! Not unique, so no point
6288                         * looking further.
6289                         */
6290
6291                        break;
6292                    }
6293                    targetCmdObj = tmpObj;
6294                }
6295                Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
6296            }
6297            Tcl_DictObjDone(&s);
6298
6299            /*
6300             * If we have anything other than a single match, we've failed the
6301             * unique prefix check.
6302             */
6303
6304            if (matched != 1) {
6305                return TCL_ERROR;
6306            }
6307        } else {
6308            return TCL_ERROR;
6309        }
6310    }
6311
6312    /*
6313     * OK, we definitely map to something. But what?
6314     *
6315     * The command we map to is the first word out of the map element. Note
6316     * that we also reject dealing with multi-element rewrites if we are in a
6317     * safe interpreter, as there is otherwise a (highly gnarly!) way to make
6318     * Tcl crash open to exploit.
6319     */
6320
6321  doneMapLookup:
6322    if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
6323        return TCL_ERROR;
6324    }
6325    if (len > 1 && Tcl_IsSafe(interp)) {
6326        return TCL_ERROR;
6327    }
6328    targetCmdObj = elems[0];
6329
6330    Tcl_IncrRefCount(targetCmdObj);
6331    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
6332    TclDecrRefCount(targetCmdObj);
6333    if (cmdPtr == NULL || cmdPtr->compileProc == NULL) {
6334        /*
6335         * Maps to an undefined command or a command without a compiler.
6336         * Cannot compile.
6337         */
6338
6339        return TCL_ERROR;
6340    }
6341
6342    /*
6343     * Now we've done the mapping process, can now actually try to compile.
6344     * We do this by handing off to the subcommand's actual compiler. But to
6345     * do that, we have to perform some trickery to rewrite the arguments.
6346     */
6347
6348    TclParseInit(interp, NULL, 0, &synthetic);
6349    synthetic.numWords = parsePtr->numWords - 2 + len;
6350    TclGrowParseTokenArray(&synthetic, 2*len);
6351    synthetic.numTokens = 2*len;
6352
6353    /*
6354     * Now we have the space to work in, install something rewritten. Note
6355     * that we are here praying for all our might that none of these words are
6356     * a script; the error detection code will crash if that happens and there
6357     * is nothing we can do to avoid it!
6358     */
6359
6360    for (i=0 ; i<len ; i++) {
6361        int sclen;
6362        const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
6363
6364        synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
6365        synthetic.tokenPtr[2*i].start = str;
6366        synthetic.tokenPtr[2*i].size = sclen;
6367        synthetic.tokenPtr[2*i].numComponents = 1;
6368
6369        synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
6370        synthetic.tokenPtr[2*i+1].start = str;
6371        synthetic.tokenPtr[2*i+1].size = sclen;
6372        synthetic.tokenPtr[2*i+1].numComponents = 0;
6373    }
6374
6375    /*
6376     * Copy over the real argument tokens.
6377     */
6378
6379    for (i=len; i<synthetic.numWords; i++) {
6380        int toCopy;
6381        tokenPtr = TokenAfter(tokenPtr);
6382        toCopy = tokenPtr->numComponents + 1;
6383        TclGrowParseTokenArray(&synthetic, toCopy);
6384        memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
6385                sizeof(Tcl_Token) * toCopy);
6386        synthetic.numTokens += toCopy;
6387    }
6388
6389    /*
6390     * Hand off compilation to the subcommand compiler. At last!
6391     */
6392
6393    result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
6394
6395    /*
6396     * Clean up if necessary.
6397     */
6398
6399    Tcl_FreeParse(&synthetic);
6400    return result;
6401}
6402
6403/*
6404 *----------------------------------------------------------------------
6405 *
6406 * TclCompileInfoExistsCmd --
6407 *
6408 *      Procedure called to compile the "info exists" subcommand.
6409 *
6410 * Results:
6411 *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
6412 *      evaluation to runtime.
6413 *
6414 * Side effects:
6415 *      Instructions are added to envPtr to execute the "info exists"
6416 *      subcommand at runtime.
6417 *
6418 *----------------------------------------------------------------------
6419 */
6420
6421int
6422TclCompileInfoExistsCmd(
6423    Tcl_Interp *interp,         /* Used for error reporting. */
6424    Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
6425                                 * created by Tcl_ParseCommand. */
6426    Command *cmdPtr,            /* Points to defintion of command being
6427                                 * compiled. */
6428    CompileEnv *envPtr)         /* Holds resulting instructions. */
6429{
6430    Tcl_Token *tokenPtr;
6431    int isScalar, simpleVarName, localIndex;
6432    DefineLineInformation;      /* TIP #280 */
6433
6434    if (parsePtr->numWords != 2) {
6435        return TCL_ERROR;
6436    }
6437
6438    /*
6439     * Decide if we can use a frame slot for the var/array name or if we need
6440     * to emit code to compute and push the name at runtime. We use a frame
6441     * slot (entry in the array of local vars) if we are compiling a procedure
6442     * body and if the name is simple text that does not include namespace
6443     * qualifiers.
6444     */
6445
6446    tokenPtr = TokenAfter(parsePtr->tokenPtr);
6447    PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
6448            &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]);
6449
6450    /*
6451     * Emit instruction to check the variable for existence.
6452     */
6453
6454    if (simpleVarName) {
6455        if (isScalar) {
6456            if (localIndex < 0) {
6457                TclEmitOpcode(INST_EXIST_STK, envPtr);
6458            } else {
6459                TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr);
6460            }
6461        } else {
6462            if (localIndex < 0) {
6463                TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr);
6464            } else {
6465                TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr);
6466            }
6467        }
6468    } else {
6469        TclEmitOpcode(INST_EXIST_STK, envPtr);
6470    }
6471
6472    return TCL_OK;
6473}
6474
6475/*
6476 * Local Variables:
6477 * mode: c
6478 * c-basic-offset: 4
6479 * fill-column: 78
6480 * End:
6481 */
Note: See TracBrowser for help on using the repository browser.