util/src/TclTk/tcl8.6.12/generic/tclCompCmdsGR.c

   1 /*
   2  * tclCompCmdsGR.c --
   3  *
   4  *      This file contains compilation procedures that compile various Tcl
   5  *      commands (beginning with the letters 'g' through 'r') into a sequence
   6  *      of instructions ("bytecodes").
   7  *
   8  * Copyright (c) 1997-1998 Sun Microsystems, Inc.
   9  * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  10  * Copyright (c) 2002 ActiveState Corporation.
  11  * Copyright (c) 2004-2013 by Donal K. Fellows.
  12  *
  13  * See the file "license.terms" for information on usage and redistribution of
  14  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15  */
  16
  17 #include "tclInt.h"
  18 #include "tclCompile.h"
  19 #include <assert.h>
  20
  21 /*
  22  * Prototypes for procedures defined later in this file:
  23  */
  24
  25 static void             CompileReturnInternal(CompileEnv *envPtr,
  26                             unsigned char op, int code, int level,
  27                             Tcl_Obj *returnOpts);
  28 static int              IndexTailVarIfKnown(Tcl_Interp *interp,
  29                             Tcl_Token *varTokenPtr, CompileEnv *envPtr);
  30
  31 \f
  32 /*
  33  *----------------------------------------------------------------------
  34  *
  35  * TclGetIndexFromToken --
  36  *
  37  *      Parse a token to determine if an index value is known at
  38  *      compile time.
  39  *
  40  * Returns:
  41  *      TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
  42  *
  43  * Side effects:
  44  *      When TCL_OK is returned, the encoded index value is written
  45  *      to *index.
  46  *
  47  *----------------------------------------------------------------------
  48  */
  49
  50 int
  51 TclGetIndexFromToken(
  52     Tcl_Token *tokenPtr,
  53     int before,
  54     int after,
  55     int *indexPtr)
  56 {
  57     Tcl_Obj *tmpObj = Tcl_NewObj();
  58     int result = TCL_ERROR;
  59
  60     if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
  61         result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr);
  62     }
  63     Tcl_DecrRefCount(tmpObj);
  64     return result;
  65 }
  66 \f
  67 /*
  68  *----------------------------------------------------------------------
  69  *
  70  * TclCompileGlobalCmd --
  71  *
  72  *      Procedure called to compile the "global" command.
  73  *
  74  * Results:
  75  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
  76  *      evaluation to runtime.
  77  *
  78  * Side effects:
  79  *      Instructions are added to envPtr to execute the "global" command at
  80  *      runtime.
  81  *
  82  *----------------------------------------------------------------------
  83  */
  84
  85 int
  86 TclCompileGlobalCmd(
  87     Tcl_Interp *interp,         /* Used for error reporting. */
  88     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
  89                                  * created by Tcl_ParseCommand. */
  90     Command *cmdPtr,            /* Points to defintion of command being
  91                                  * compiled. */
  92     CompileEnv *envPtr)         /* Holds resulting instructions. */
  93 {
  94     DefineLineInformation;      /* TIP #280 */
  95     Tcl_Token *varTokenPtr;
  96     int localIndex, numWords, i;
  97
  98     /* TODO: Consider support for compiling expanded args. */
  99     numWords = parsePtr->numWords;
 100     if (numWords < 2) {
 101         return TCL_ERROR;
 102     }
 103
 104     /*
 105      * 'global' has no effect outside of proc bodies; handle that at runtime
 106      */
 107
 108     if (envPtr->procPtr == NULL) {
 109         return TCL_ERROR;
 110     }
 111
 112     /*
 113      * Push the namespace
 114      */
 115
 116     PushStringLiteral(envPtr, "::");
 117
 118     /*
 119      * Loop over the variables.
 120      */
 121
 122     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 123     for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
 124         localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
 125
 126         if (localIndex < 0) {
 127             return TCL_ERROR;
 128         }
 129
 130         /* TODO: Consider what value can pass through the
 131          * IndexTailVarIfKnown() screen.  Full CompileWord()
 132          * likely does not apply here.  Push known value instead. */
 133         CompileWord(envPtr, varTokenPtr, interp, i);
 134         TclEmitInstInt4(        INST_NSUPVAR, localIndex,       envPtr);
 135     }
 136
 137     /*
 138      * Pop the namespace, and set the result to empty
 139      */
 140
 141     TclEmitOpcode(              INST_POP,                       envPtr);
 142     PushStringLiteral(envPtr, "");
 143     return TCL_OK;
 144 }
 145 \f
 146 /*
 147  *----------------------------------------------------------------------
 148  *
 149  * TclCompileIfCmd --
 150  *
 151  *      Procedure called to compile the "if" command.
 152  *
 153  * Results:
 154  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
 155  *      evaluation to runtime.
 156  *
 157  * Side effects:
 158  *      Instructions are added to envPtr to execute the "if" command at
 159  *      runtime.
 160  *
 161  *----------------------------------------------------------------------
 162  */
 163
 164 int
 165 TclCompileIfCmd(
 166     Tcl_Interp *interp,         /* Used for error reporting. */
 167     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 168                                  * created by Tcl_ParseCommand. */
 169     Command *cmdPtr,            /* Points to defintion of command being
 170                                  * compiled. */
 171     CompileEnv *envPtr)         /* Holds resulting instructions. */
 172 {
 173     DefineLineInformation;      /* TIP #280 */
 174     JumpFixupArray jumpFalseFixupArray;
 175                                 /* Used to fix the ifFalse jump after each
 176                                  * test when its target PC is determined. */
 177     JumpFixupArray jumpEndFixupArray;
 178                                 /* Used to fix the jump after each "then" body
 179                                  * to the end of the "if" when that PC is
 180                                  * determined. */
 181     Tcl_Token *tokenPtr, *testTokenPtr;
 182     int jumpIndex = 0;          /* Avoid compiler warning. */
 183     int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
 184     const char *word;
 185     int realCond = 1;           /* Set to 0 for static conditions:
 186                                  * "if 0 {..}" */
 187     int boolVal;                /* Value of static condition. */
 188     int compileScripts = 1;
 189
 190     /*
 191      * Only compile the "if" command if all arguments are simple words, in
 192      * order to insure correct substitution [Bug 219166]
 193      */
 194
 195     tokenPtr = parsePtr->tokenPtr;
 196     wordIdx = 0;
 197     numWords = parsePtr->numWords;
 198
 199     for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
 200         if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
 201             return TCL_ERROR;
 202         }
 203         tokenPtr = TokenAfter(tokenPtr);
 204     }
 205
 206     TclInitJumpFixupArray(&jumpFalseFixupArray);
 207     TclInitJumpFixupArray(&jumpEndFixupArray);
 208     code = TCL_OK;
 209
 210     /*
 211      * Each iteration of this loop compiles one "if expr ?then? body" or
 212      * "elseif expr ?then? body" clause.
 213      */
 214
 215     tokenPtr = parsePtr->tokenPtr;
 216     wordIdx = 0;
 217     while (wordIdx < numWords) {
 218         /*
 219          * Stop looping if the token isn't "if" or "elseif".
 220          */
 221
 222         word = tokenPtr[1].start;
 223         numBytes = tokenPtr[1].size;
 224         if ((tokenPtr == parsePtr->tokenPtr)
 225                 || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
 226             tokenPtr = TokenAfter(tokenPtr);
 227             wordIdx++;
 228         } else {
 229             break;
 230         }
 231         if (wordIdx >= numWords) {
 232             code = TCL_ERROR;
 233             goto done;
 234         }
 235
 236         /*
 237          * Compile the test expression then emit the conditional jump around
 238          * the "then" part.
 239          */
 240
 241         testTokenPtr = tokenPtr;
 242
 243         if (realCond) {
 244             /*
 245              * Find out if the condition is a constant.
 246              */
 247
 248             Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
 249                     testTokenPtr[1].size);
 250
 251             Tcl_IncrRefCount(boolObj);
 252             code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
 253             TclDecrRefCount(boolObj);
 254             if (code == TCL_OK) {
 255                 /*
 256                  * A static condition.
 257                  */
 258
 259                 realCond = 0;
 260                 if (!boolVal) {
 261                     compileScripts = 0;
 262                 }
 263             } else {
 264                 SetLineInformation(wordIdx);
 265                 Tcl_ResetResult(interp);
 266                 TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
 267                 if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
 268                     TclExpandJumpFixupArray(&jumpFalseFixupArray);
 269                 }
 270                 jumpIndex = jumpFalseFixupArray.next;
 271                 jumpFalseFixupArray.next++;
 272                 TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
 273                         jumpFalseFixupArray.fixup+jumpIndex);
 274             }
 275             code = TCL_OK;
 276         }
 277
 278         /*
 279          * Skip over the optional "then" before the then clause.
 280          */
 281
 282         tokenPtr = TokenAfter(testTokenPtr);
 283         wordIdx++;
 284         if (wordIdx >= numWords) {
 285             code = TCL_ERROR;
 286             goto done;
 287         }
 288         if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
 289             word = tokenPtr[1].start;
 290             numBytes = tokenPtr[1].size;
 291             if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
 292                 tokenPtr = TokenAfter(tokenPtr);
 293                 wordIdx++;
 294                 if (wordIdx >= numWords) {
 295                     code = TCL_ERROR;
 296                     goto done;
 297                 }
 298             }
 299         }
 300
 301         /*
 302          * Compile the "then" command body.
 303          */
 304
 305         if (compileScripts) {
 306             BODY(tokenPtr, wordIdx);
 307         }
 308
 309         if (realCond) {
 310             /*
 311              * Jump to the end of the "if" command. Both jumpFalseFixupArray
 312              * and jumpEndFixupArray are indexed by "jumpIndex".
 313              */
 314
 315             if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
 316                 TclExpandJumpFixupArray(&jumpEndFixupArray);
 317             }
 318             jumpEndFixupArray.next++;
 319             TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
 320                     jumpEndFixupArray.fixup+jumpIndex);
 321
 322             /*
 323              * Fix the target of the jumpFalse after the test. Generate a 4
 324              * byte jump if the distance is > 120 bytes. This is conservative,
 325              * and ensures that we won't have to replace this jump if we later
 326              * also need to replace the proceeding jump to the end of the "if"
 327              * with a 4 byte jump.
 328              */
 329
 330             TclAdjustStackDepth(-1, envPtr);
 331             if (TclFixupForwardJumpToHere(envPtr,
 332                     jumpFalseFixupArray.fixup+jumpIndex, 120)) {
 333                 /*
 334                  * Adjust the code offset for the proceeding jump to the end
 335                  * of the "if" command.
 336                  */
 337
 338                 jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
 339             }
 340         } else if (boolVal) {
 341             /*
 342              * We were processing an "if 1 {...}"; stop compiling scripts.
 343              */
 344
 345             compileScripts = 0;
 346         } else {
 347             /*
 348              * We were processing an "if 0 {...}"; reset so that the rest
 349              * (elseif, else) is compiled correctly.
 350              */
 351
 352             realCond = 1;
 353             compileScripts = 1;
 354         }
 355
 356         tokenPtr = TokenAfter(tokenPtr);
 357         wordIdx++;
 358     }
 359
 360     /*
 361      * Check for the optional else clause. Do not compile anything if this was
 362      * an "if 1 {...}" case.
 363      */
 364
 365     if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
 366         /*
 367          * There is an else clause. Skip over the optional "else" word.
 368          */
 369
 370         word = tokenPtr[1].start;
 371         numBytes = tokenPtr[1].size;
 372         if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
 373             tokenPtr = TokenAfter(tokenPtr);
 374             wordIdx++;
 375             if (wordIdx >= numWords) {
 376                 code = TCL_ERROR;
 377                 goto done;
 378             }
 379         }
 380
 381         if (compileScripts) {
 382             /*
 383              * Compile the else command body.
 384              */
 385
 386             BODY(tokenPtr, wordIdx);
 387         }
 388
 389         /*
 390          * Make sure there are no words after the else clause.
 391          */
 392
 393         wordIdx++;
 394         if (wordIdx < numWords) {
 395             code = TCL_ERROR;
 396             goto done;
 397         }
 398     } else {
 399         /*
 400          * No else clause: the "if" command's result is an empty string.
 401          */
 402
 403         if (compileScripts) {
 404             PushStringLiteral(envPtr, "");
 405         }
 406     }
 407
 408     /*
 409      * Fix the unconditional jumps to the end of the "if" command.
 410      */
 411
 412     for (j = jumpEndFixupArray.next;  j > 0;  j--) {
 413         jumpIndex = (j - 1);    /* i.e. process the closest jump first. */
 414         if (TclFixupForwardJumpToHere(envPtr,
 415                 jumpEndFixupArray.fixup+jumpIndex, 127)) {
 416             /*
 417              * Adjust the immediately preceeding "ifFalse" jump. We moved it's
 418              * target (just after this jump) down three bytes.
 419              */
 420
 421             unsigned char *ifFalsePc = envPtr->codeStart
 422                     + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
 423             unsigned char opCode = *ifFalsePc;
 424
 425             if (opCode == INST_JUMP_FALSE1) {
 426                 jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
 427                 jumpFalseDist += 3;
 428                 TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
 429             } else if (opCode == INST_JUMP_FALSE4) {
 430                 jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
 431                 jumpFalseDist += 3;
 432                 TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
 433             } else {
 434                 Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
 435             }
 436         }
 437     }
 438
 439     /*
 440      * Free the jumpFixupArray array if malloc'ed storage was used.
 441      */
 442
 443   done:
 444     TclFreeJumpFixupArray(&jumpFalseFixupArray);
 445     TclFreeJumpFixupArray(&jumpEndFixupArray);
 446     return code;
 447 }
 448 \f
 449 /*
 450  *----------------------------------------------------------------------
 451  *
 452  * TclCompileIncrCmd --
 453  *
 454  *      Procedure called to compile the "incr" command.
 455  *
 456  * Results:
 457  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
 458  *      evaluation to runtime.
 459  *
 460  * Side effects:
 461  *      Instructions are added to envPtr to execute the "incr" command at
 462  *      runtime.
 463  *
 464  *----------------------------------------------------------------------
 465  */
 466
 467 int
 468 TclCompileIncrCmd(
 469     Tcl_Interp *interp,         /* Used for error reporting. */
 470     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 471                                  * created by Tcl_ParseCommand. */
 472     Command *cmdPtr,            /* Points to defintion of command being
 473                                  * compiled. */
 474     CompileEnv *envPtr)         /* Holds resulting instructions. */
 475 {
 476     DefineLineInformation;      /* TIP #280 */
 477     Tcl_Token *varTokenPtr, *incrTokenPtr;
 478     int isScalar, localIndex, haveImmValue, immValue;
 479
 480     if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
 481         return TCL_ERROR;
 482     }
 483
 484     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 485
 486     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
 487             &localIndex, &isScalar, 1);
 488
 489     /*
 490      * If an increment is given, push it, but see first if it's a small
 491      * integer.
 492      */
 493
 494     haveImmValue = 0;
 495     immValue = 1;
 496     if (parsePtr->numWords == 3) {
 497         incrTokenPtr = TokenAfter(varTokenPtr);
 498         if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
 499             const char *word = incrTokenPtr[1].start;
 500             int numBytes = incrTokenPtr[1].size;
 501             int code;
 502             Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
 503
 504             Tcl_IncrRefCount(intObj);
 505             code = TclGetIntFromObj(NULL, intObj, &immValue);
 506             TclDecrRefCount(intObj);
 507             if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
 508                 haveImmValue = 1;
 509             }
 510             if (!haveImmValue) {
 511                 PushLiteral(envPtr, word, numBytes);
 512             }
 513         } else {
 514             SetLineInformation(2);
 515             CompileTokens(envPtr, incrTokenPtr, interp);
 516         }
 517     } else {                    /* No incr amount given so use 1. */
 518         haveImmValue = 1;
 519     }
 520
 521     /*
 522      * Emit the instruction to increment the variable.
 523      */
 524
 525     if (isScalar) {     /* Simple scalar variable. */
 526         if (localIndex >= 0) {
 527             if (haveImmValue) {
 528                 TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
 529                 TclEmitInt1(immValue, envPtr);
 530             } else {
 531                 TclEmitInstInt1(INST_INCR_SCALAR1, localIndex,  envPtr);
 532             }
 533         } else {
 534             if (haveImmValue) {
 535                 TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
 536             } else {
 537                 TclEmitOpcode(  INST_INCR_STK,          envPtr);
 538             }
 539         }
 540     } else {                    /* Simple array variable. */
 541         if (localIndex >= 0) {
 542             if (haveImmValue) {
 543                 TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
 544                 TclEmitInt1(immValue, envPtr);
 545             } else {
 546                 TclEmitInstInt1(INST_INCR_ARRAY1, localIndex,   envPtr);
 547             }
 548         } else {
 549             if (haveImmValue) {
 550                 TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
 551             } else {
 552                 TclEmitOpcode(  INST_INCR_ARRAY_STK,            envPtr);
 553             }
 554         }
 555     }
 556
 557     return TCL_OK;
 558 }
 559 \f
 560 /*
 561  *----------------------------------------------------------------------
 562  *
 563  * TclCompileInfo*Cmd --
 564  *
 565  *      Procedures called to compile "info" subcommands.
 566  *
 567  * Results:
 568  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
 569  *      evaluation to runtime.
 570  *
 571  * Side effects:
 572  *      Instructions are added to envPtr to execute the "info" subcommand at
 573  *      runtime.
 574  *
 575  *----------------------------------------------------------------------
 576  */
 577
 578 int
 579 TclCompileInfoCommandsCmd(
 580     Tcl_Interp *interp,         /* Used for error reporting. */
 581     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 582                                  * created by Tcl_ParseCommand. */
 583     Command *cmdPtr,            /* Points to defintion of command being
 584                                  * compiled. */
 585     CompileEnv *envPtr)
 586 {
 587     DefineLineInformation;      /* TIP #280 */
 588     Tcl_Token *tokenPtr;
 589     Tcl_Obj *objPtr;
 590     char *bytes;
 591
 592     /*
 593      * We require one compile-time known argument for the case we can compile.
 594      */
 595
 596     if (parsePtr->numWords == 1) {
 597         return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 598     } else if (parsePtr->numWords != 2) {
 599         return TCL_ERROR;
 600     }
 601     tokenPtr = TokenAfter(parsePtr->tokenPtr);
 602     objPtr = Tcl_NewObj();
 603     Tcl_IncrRefCount(objPtr);
 604     if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
 605         goto notCompilable;
 606     }
 607     bytes = Tcl_GetString(objPtr);
 608
 609     /*
 610      * We require that the argument start with "::" and not have any of "*\[?"
 611      * in it. (Theoretically, we should look in only the final component, but
 612      * the difference is so slight given current naming practices.)
 613      */
 614
 615     if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
 616         goto notCompilable;
 617     }
 618     Tcl_DecrRefCount(objPtr);
 619
 620     /*
 621      * Confirmed as a literal that will not frighten the horses. Compile. Note
 622      * that the result needs to be list-ified.
 623      */
 624
 625     /* TODO: Just push the known value */
 626     CompileWord(envPtr, tokenPtr,               interp, 1);
 627     TclEmitOpcode(      INST_RESOLVE_COMMAND,   envPtr);
 628     TclEmitOpcode(      INST_DUP,               envPtr);
 629     TclEmitOpcode(      INST_STR_LEN,           envPtr);
 630     TclEmitInstInt1(    INST_JUMP_FALSE1, 7,    envPtr);
 631     TclEmitInstInt4(    INST_LIST, 1,           envPtr);
 632     return TCL_OK;
 633
 634   notCompilable:
 635     Tcl_DecrRefCount(objPtr);
 636     return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 637 }
 638
 639 int
 640 TclCompileInfoCoroutineCmd(
 641     Tcl_Interp *interp,         /* Used for error reporting. */
 642     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 643                                  * created by Tcl_ParseCommand. */
 644     Command *cmdPtr,            /* Points to defintion of command being
 645                                  * compiled. */
 646     CompileEnv *envPtr)         /* Holds resulting instructions. */
 647 {
 648     /*
 649      * Only compile [info coroutine] without arguments.
 650      */
 651
 652     if (parsePtr->numWords != 1) {
 653         return TCL_ERROR;
 654     }
 655
 656     /*
 657      * Not much to do; we compile to a single instruction...
 658      */
 659
 660     TclEmitOpcode(              INST_COROUTINE_NAME,            envPtr);
 661     return TCL_OK;
 662 }
 663
 664 int
 665 TclCompileInfoExistsCmd(
 666     Tcl_Interp *interp,         /* Used for error reporting. */
 667     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 668                                  * created by Tcl_ParseCommand. */
 669     Command *cmdPtr,            /* Points to defintion of command being
 670                                  * compiled. */
 671     CompileEnv *envPtr)         /* Holds resulting instructions. */
 672 {
 673     DefineLineInformation;      /* TIP #280 */
 674     Tcl_Token *tokenPtr;
 675     int isScalar, localIndex;
 676
 677     if (parsePtr->numWords != 2) {
 678         return TCL_ERROR;
 679     }
 680
 681     /*
 682      * Decide if we can use a frame slot for the var/array name or if we need
 683      * to emit code to compute and push the name at runtime. We use a frame
 684      * slot (entry in the array of local vars) if we are compiling a procedure
 685      * body and if the name is simple text that does not include namespace
 686      * qualifiers.
 687      */
 688
 689     tokenPtr = TokenAfter(parsePtr->tokenPtr);
 690     PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1);
 691
 692     /*
 693      * Emit instruction to check the variable for existence.
 694      */
 695
 696     if (isScalar) {
 697         if (localIndex < 0) {
 698             TclEmitOpcode(      INST_EXIST_STK,                 envPtr);
 699         } else {
 700             TclEmitInstInt4(    INST_EXIST_SCALAR, localIndex,  envPtr);
 701         }
 702     } else {
 703         if (localIndex < 0) {
 704             TclEmitOpcode(      INST_EXIST_ARRAY_STK,           envPtr);
 705         } else {
 706             TclEmitInstInt4(    INST_EXIST_ARRAY, localIndex,   envPtr);
 707         }
 708     }
 709
 710     return TCL_OK;
 711 }
 712
 713 int
 714 TclCompileInfoLevelCmd(
 715     Tcl_Interp *interp,         /* Used for error reporting. */
 716     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 717                                  * created by Tcl_ParseCommand. */
 718     Command *cmdPtr,            /* Points to defintion of command being
 719                                  * compiled. */
 720     CompileEnv *envPtr)         /* Holds resulting instructions. */
 721 {
 722     /*
 723      * Only compile [info level] without arguments or with a single argument.
 724      */
 725
 726     if (parsePtr->numWords == 1) {
 727         /*
 728          * Not much to do; we compile to a single instruction...
 729          */
 730
 731         TclEmitOpcode(          INST_INFO_LEVEL_NUM,            envPtr);
 732     } else if (parsePtr->numWords != 2) {
 733         return TCL_ERROR;
 734     } else {
 735         DefineLineInformation;  /* TIP #280 */
 736
 737         /*
 738          * Compile the argument, then add the instruction to convert it into a
 739          * list of arguments.
 740          */
 741
 742         CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1);
 743         TclEmitOpcode(          INST_INFO_LEVEL_ARGS,           envPtr);
 744     }
 745     return TCL_OK;
 746 }
 747
 748 int
 749 TclCompileInfoObjectClassCmd(
 750     Tcl_Interp *interp,         /* Used for error reporting. */
 751     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 752                                  * created by Tcl_ParseCommand. */
 753     Command *cmdPtr,            /* Points to defintion of command being
 754                                  * compiled. */
 755     CompileEnv *envPtr)
 756 {
 757     DefineLineInformation;      /* TIP #280 */
 758     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
 759
 760     if (parsePtr->numWords != 2) {
 761         return TCL_ERROR;
 762     }
 763     CompileWord(envPtr,         tokenPtr,               interp, 1);
 764     TclEmitOpcode(              INST_TCLOO_CLASS,       envPtr);
 765     return TCL_OK;
 766 }
 767
 768 int
 769 TclCompileInfoObjectIsACmd(
 770     Tcl_Interp *interp,         /* Used for error reporting. */
 771     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 772                                  * created by Tcl_ParseCommand. */
 773     Command *cmdPtr,            /* Points to defintion of command being
 774                                  * compiled. */
 775     CompileEnv *envPtr)
 776 {
 777     DefineLineInformation;      /* TIP #280 */
 778     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
 779
 780     /*
 781      * We only handle [info object isa object <somevalue>]. The first three
 782      * words are compressed to a single token by the ensemble compilation
 783      * engine.
 784      */
 785
 786     if (parsePtr->numWords != 3) {
 787         return TCL_ERROR;
 788     }
 789     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
 790             || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
 791         return TCL_ERROR;
 792     }
 793     tokenPtr = TokenAfter(tokenPtr);
 794
 795     /*
 796      * Issue the code.
 797      */
 798
 799     CompileWord(envPtr,         tokenPtr,               interp, 2);
 800     TclEmitOpcode(              INST_TCLOO_IS_OBJECT,   envPtr);
 801     return TCL_OK;
 802 }
 803
 804 int
 805 TclCompileInfoObjectNamespaceCmd(
 806     Tcl_Interp *interp,         /* Used for error reporting. */
 807     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 808                                  * created by Tcl_ParseCommand. */
 809     Command *cmdPtr,            /* Points to defintion of command being
 810                                  * compiled. */
 811     CompileEnv *envPtr)
 812 {
 813     DefineLineInformation;      /* TIP #280 */
 814     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
 815
 816     if (parsePtr->numWords != 2) {
 817         return TCL_ERROR;
 818     }
 819     CompileWord(envPtr,         tokenPtr,               interp, 1);
 820     TclEmitOpcode(              INST_TCLOO_NS,          envPtr);
 821     return TCL_OK;
 822 }
 823 \f
 824 /*
 825  *----------------------------------------------------------------------
 826  *
 827  * TclCompileLappendCmd --
 828  *
 829  *      Procedure called to compile the "lappend" command.
 830  *
 831  * Results:
 832  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
 833  *      evaluation to runtime.
 834  *
 835  * Side effects:
 836  *      Instructions are added to envPtr to execute the "lappend" command at
 837  *      runtime.
 838  *
 839  *----------------------------------------------------------------------
 840  */
 841
 842 int
 843 TclCompileLappendCmd(
 844     Tcl_Interp *interp,         /* Used for error reporting. */
 845     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 846                                  * created by Tcl_ParseCommand. */
 847     Command *cmdPtr,            /* Points to defintion of command being
 848                                  * compiled. */
 849     CompileEnv *envPtr)         /* Holds resulting instructions. */
 850 {
 851     DefineLineInformation;      /* TIP #280 */
 852     Tcl_Token *varTokenPtr, *valueTokenPtr;
 853     int isScalar, localIndex, numWords, i;
 854
 855     /* TODO: Consider support for compiling expanded args. */
 856     numWords = parsePtr->numWords;
 857     if (numWords < 3) {
 858         return TCL_ERROR;
 859     }
 860
 861     if (numWords != 3 || envPtr->procPtr == NULL) {
 862         goto lappendMultiple;
 863     }
 864
 865     /*
 866      * Decide if we can use a frame slot for the var/array name or if we
 867      * need to emit code to compute and push the name at runtime. We use a
 868      * frame slot (entry in the array of local vars) if we are compiling a
 869      * procedure body and if the name is simple text that does not include
 870      * namespace qualifiers.
 871      */
 872
 873     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 874
 875     PushVarNameWord(interp, varTokenPtr, envPtr, 0,
 876             &localIndex, &isScalar, 1);
 877
 878     /*
 879      * If we are doing an assignment, push the new value. In the no values
 880      * case, create an empty object.
 881      */
 882
 883     if (numWords > 2) {
 884         valueTokenPtr = TokenAfter(varTokenPtr);
 885
 886         CompileWord(envPtr, valueTokenPtr, interp, 2);
 887     }
 888
 889     /*
 890      * Emit instructions to set/get the variable.
 891      */
 892
 893     /*
 894      * The *_STK opcodes should be refactored to make better use of existing
 895      * LOAD/STORE instructions.
 896      */
 897
 898     if (isScalar) {
 899         if (localIndex < 0) {
 900             TclEmitOpcode(      INST_LAPPEND_STK,               envPtr);
 901         } else {
 902             Emit14Inst(         INST_LAPPEND_SCALAR, localIndex, envPtr);
 903         }
 904     } else {
 905         if (localIndex < 0) {
 906             TclEmitOpcode(      INST_LAPPEND_ARRAY_STK,         envPtr);
 907         } else {
 908             Emit14Inst(         INST_LAPPEND_ARRAY, localIndex, envPtr);
 909         }
 910     }
 911
 912     return TCL_OK;
 913
 914   lappendMultiple:
 915     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 916     PushVarNameWord(interp, varTokenPtr, envPtr, 0,
 917             &localIndex, &isScalar, 1);
 918     valueTokenPtr = TokenAfter(varTokenPtr);
 919     for (i = 2 ; i < numWords ; i++) {
 920         CompileWord(envPtr, valueTokenPtr, interp, i);
 921         valueTokenPtr = TokenAfter(valueTokenPtr);
 922     }
 923     TclEmitInstInt4(        INST_LIST, numWords-2,              envPtr);
 924     if (isScalar) {
 925         if (localIndex < 0) {
 926             TclEmitOpcode(  INST_LAPPEND_LIST_STK,              envPtr);
 927         } else {
 928             TclEmitInstInt4(INST_LAPPEND_LIST, localIndex,      envPtr);
 929         }
 930     } else {
 931         if (localIndex < 0) {
 932             TclEmitOpcode(  INST_LAPPEND_LIST_ARRAY_STK,        envPtr);
 933         } else {
 934             TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr);
 935         }
 936     }
 937     return TCL_OK;
 938 }
 939 \f
 940 /*
 941  *----------------------------------------------------------------------
 942  *
 943  * TclCompileLassignCmd --
 944  *
 945  *      Procedure called to compile the "lassign" command.
 946  *
 947  * Results:
 948  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
 949  *      evaluation to runtime.
 950  *
 951  * Side effects:
 952  *      Instructions are added to envPtr to execute the "lassign" command at
 953  *      runtime.
 954  *
 955  *----------------------------------------------------------------------
 956  */
 957
 958 int
 959 TclCompileLassignCmd(
 960     Tcl_Interp *interp,         /* Used for error reporting. */
 961     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 962                                  * created by Tcl_ParseCommand. */
 963     Command *cmdPtr,            /* Points to defintion of command being
 964                                  * compiled. */
 965     CompileEnv *envPtr)         /* Holds resulting instructions. */
 966 {
 967     DefineLineInformation;      /* TIP #280 */
 968     Tcl_Token *tokenPtr;
 969     int isScalar, localIndex, numWords, idx;
 970
 971     numWords = parsePtr->numWords;
 972
 973     /*
 974      * Check for command syntax error, but we'll punt that to runtime.
 975      */
 976
 977     if (numWords < 3) {
 978         return TCL_ERROR;
 979     }
 980
 981     /*
 982      * Generate code to push list being taken apart by [lassign].
 983      */
 984
 985     tokenPtr = TokenAfter(parsePtr->tokenPtr);
 986     CompileWord(envPtr, tokenPtr, interp, 1);
 987
 988     /*
 989      * Generate code to assign values from the list to variables.
 990      */
 991
 992     for (idx=0 ; idx<numWords-2 ; idx++) {
 993         tokenPtr = TokenAfter(tokenPtr);
 994
 995         /*
 996          * Generate the next variable name.
 997          */
 998
 999         PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
1000                 &isScalar, idx+2);
1001
1002         /*
1003          * Emit instructions to get the idx'th item out of the list value on
1004          * the stack and assign it to the variable.
1005          */
1006
1007         if (isScalar) {
1008             if (localIndex >= 0) {
1009                 TclEmitOpcode(  INST_DUP,                       envPtr);
1010                 TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,       envPtr);
1011                 Emit14Inst(     INST_STORE_SCALAR, localIndex,  envPtr);
1012                 TclEmitOpcode(  INST_POP,                       envPtr);
1013             } else {
1014                 TclEmitInstInt4(INST_OVER, 1,                   envPtr);
1015                 TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,       envPtr);
1016                 TclEmitOpcode(  INST_STORE_STK,                 envPtr);
1017                 TclEmitOpcode(  INST_POP,                       envPtr);
1018             }
1019         } else {
1020             if (localIndex >= 0) {
1021                 TclEmitInstInt4(INST_OVER, 1,                   envPtr);
1022                 TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,       envPtr);
1023                 Emit14Inst(     INST_STORE_ARRAY, localIndex,   envPtr);
1024                 TclEmitOpcode(  INST_POP,                       envPtr);
1025             } else {
1026                 TclEmitInstInt4(INST_OVER, 2,                   envPtr);
1027                 TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,       envPtr);
1028                 TclEmitOpcode(  INST_STORE_ARRAY_STK,           envPtr);
1029                 TclEmitOpcode(  INST_POP,                       envPtr);
1030             }
1031         }
1032     }
1033
1034     /*
1035      * Generate code to leave the rest of the list on the stack.
1036      */
1037
1038     TclEmitInstInt4(            INST_LIST_RANGE_IMM, idx,       envPtr);
1039     TclEmitInt4(                        TCL_INDEX_END,          envPtr);
1040
1041     return TCL_OK;
1042 }
1043 \f
1044 /*
1045  *----------------------------------------------------------------------
1046  *
1047  * TclCompileLindexCmd --
1048  *
1049  *      Procedure called to compile the "lindex" command.
1050  *
1051  * Results:
1052  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1053  *      evaluation to runtime.
1054  *
1055  * Side effects:
1056  *      Instructions are added to envPtr to execute the "lindex" command at
1057  *      runtime.
1058  *
1059  *----------------------------------------------------------------------
1060  */
1061
1062 int
1063 TclCompileLindexCmd(
1064     Tcl_Interp *interp,         /* Used for error reporting. */
1065     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1066                                  * created by Tcl_ParseCommand. */
1067     Command *cmdPtr,            /* Points to defintion of command being
1068                                  * compiled. */
1069     CompileEnv *envPtr)         /* Holds resulting instructions. */
1070 {
1071     DefineLineInformation;      /* TIP #280 */
1072     Tcl_Token *idxTokenPtr, *valTokenPtr;
1073     int i, idx, numWords = parsePtr->numWords;
1074
1075     /*
1076      * Quit if not enough args.
1077      */
1078
1079     /* TODO: Consider support for compiling expanded args. */
1080     if (numWords <= 1) {
1081         return TCL_ERROR;
1082     }
1083
1084     valTokenPtr = TokenAfter(parsePtr->tokenPtr);
1085     if (numWords != 3) {
1086         goto emitComplexLindex;
1087     }
1088
1089     idxTokenPtr = TokenAfter(valTokenPtr);
1090     if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE,
1091             &idx) == TCL_OK) {
1092         /*
1093          * The idxTokenPtr parsed as a valid index value and was
1094          * encoded as expected by INST_LIST_INDEX_IMM.
1095          *
1096          * NOTE: that we rely on indexing before a list producing the
1097          * same result as indexing after a list.
1098          */
1099
1100         CompileWord(envPtr, valTokenPtr, interp, 1);
1101         TclEmitInstInt4(        INST_LIST_INDEX_IMM, idx,       envPtr);
1102         return TCL_OK;
1103     }
1104
1105     /*
1106      * If the value was not known at compile time, the conversion failed or
1107      * the value was negative, we just keep on going with the more complex
1108      * compilation.
1109      */
1110
1111     /*
1112      * Push the operands onto the stack.
1113      */
1114
1115   emitComplexLindex:
1116     for (i=1 ; i<numWords ; i++) {
1117         CompileWord(envPtr, valTokenPtr, interp, i);
1118         valTokenPtr = TokenAfter(valTokenPtr);
1119     }
1120
1121     /*
1122      * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
1123      * multiple index args.
1124      */
1125
1126     if (numWords == 3) {
1127         TclEmitOpcode(          INST_LIST_INDEX,                envPtr);
1128     } else {
1129         TclEmitInstInt4(        INST_LIST_INDEX_MULTI, numWords-1, envPtr);
1130     }
1131
1132     return TCL_OK;
1133 }
1134 \f
1135 /*
1136  *----------------------------------------------------------------------
1137  *
1138  * TclCompileListCmd --
1139  *
1140  *      Procedure called to compile the "list" command.
1141  *
1142  * Results:
1143  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1144  *      evaluation to runtime.
1145  *
1146  * Side effects:
1147  *      Instructions are added to envPtr to execute the "list" command at
1148  *      runtime.
1149  *
1150  *----------------------------------------------------------------------
1151  */
1152
1153 int
1154 TclCompileListCmd(
1155     Tcl_Interp *interp,         /* Used for error reporting. */
1156     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1157                                  * created by Tcl_ParseCommand. */
1158     Command *cmdPtr,            /* Points to defintion of command being
1159                                  * compiled. */
1160     CompileEnv *envPtr)         /* Holds resulting instructions. */
1161 {
1162     DefineLineInformation;      /* TIP #280 */
1163     Tcl_Token *valueTokenPtr;
1164     int i, numWords, concat, build;
1165     Tcl_Obj *listObj, *objPtr;
1166
1167     if (parsePtr->numWords == 1) {
1168         /*
1169          * [list] without arguments just pushes an empty object.
1170          */
1171
1172         PushStringLiteral(envPtr, "");
1173         return TCL_OK;
1174     }
1175
1176     /*
1177      * Test if all arguments are compile-time known. If they are, we can
1178      * implement with a simple push.
1179      */
1180
1181     numWords = parsePtr->numWords;
1182     valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
1183     listObj = Tcl_NewObj();
1184     for (i = 1; i < numWords && listObj != NULL; i++) {
1185         objPtr = Tcl_NewObj();
1186         if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) {
1187             (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
1188         } else {
1189             Tcl_DecrRefCount(objPtr);
1190             Tcl_DecrRefCount(listObj);
1191             listObj = NULL;
1192         }
1193         valueTokenPtr = TokenAfter(valueTokenPtr);
1194     }
1195     if (listObj != NULL) {
1196         TclEmitPush(TclAddLiteralObj(envPtr, listObj, NULL), envPtr);
1197         return TCL_OK;
1198     }
1199
1200     /*
1201      * Push the all values onto the stack.
1202      */
1203
1204     numWords = parsePtr->numWords;
1205     valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
1206     concat = build = 0;
1207     for (i = 1; i < numWords; i++) {
1208         if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) {
1209             TclEmitInstInt4(    INST_LIST, build,       envPtr);
1210             if (concat) {
1211                 TclEmitOpcode(  INST_LIST_CONCAT,       envPtr);
1212             }
1213             build = 0;
1214             concat = 1;
1215         }
1216         CompileWord(envPtr, valueTokenPtr, interp, i);
1217         if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
1218             if (concat) {
1219                 TclEmitOpcode(  INST_LIST_CONCAT,       envPtr);
1220             } else {
1221                 concat = 1;
1222             }
1223         } else {
1224             build++;
1225         }
1226         valueTokenPtr = TokenAfter(valueTokenPtr);
1227     }
1228     if (build > 0) {
1229         TclEmitInstInt4(        INST_LIST, build,       envPtr);
1230         if (concat) {
1231             TclEmitOpcode(      INST_LIST_CONCAT,       envPtr);
1232         }
1233     }
1234
1235     /*
1236      * If there was just one expanded word, we must ensure that it is a list
1237      * at this point. We use an [lrange ... 0 end] for this (instead of
1238      * [llength], as with literals) as we must drop any string representation
1239      * that might be hanging around.
1240      */
1241
1242     if (concat && numWords == 2) {
1243         TclEmitInstInt4(        INST_LIST_RANGE_IMM, 0, envPtr);
1244         TclEmitInt4(                    TCL_INDEX_END,  envPtr);
1245     }
1246     return TCL_OK;
1247 }
1248 \f
1249 /*
1250  *----------------------------------------------------------------------
1251  *
1252  * TclCompileLlengthCmd --
1253  *
1254  *      Procedure called to compile the "llength" command.
1255  *
1256  * Results:
1257  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1258  *      evaluation to runtime.
1259  *
1260  * Side effects:
1261  *      Instructions are added to envPtr to execute the "llength" command at
1262  *      runtime.
1263  *
1264  *----------------------------------------------------------------------
1265  */
1266
1267 int
1268 TclCompileLlengthCmd(
1269     Tcl_Interp *interp,         /* Used for error reporting. */
1270     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1271                                  * created by Tcl_ParseCommand. */
1272     Command *cmdPtr,            /* Points to defintion of command being
1273                                  * compiled. */
1274     CompileEnv *envPtr)         /* Holds resulting instructions. */
1275 {
1276     DefineLineInformation;      /* TIP #280 */
1277     Tcl_Token *varTokenPtr;
1278
1279     if (parsePtr->numWords != 2) {
1280         return TCL_ERROR;
1281     }
1282     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
1283
1284     CompileWord(envPtr, varTokenPtr, interp, 1);
1285     TclEmitOpcode(              INST_LIST_LENGTH,               envPtr);
1286     return TCL_OK;
1287 }
1288 \f
1289 /*
1290  *----------------------------------------------------------------------
1291  *
1292  * TclCompileLrangeCmd --
1293  *
1294  *      How to compile the "lrange" command. We only bother because we needed
1295  *      the opcode anyway for "lassign".
1296  *
1297  *----------------------------------------------------------------------
1298  */
1299
1300 int
1301 TclCompileLrangeCmd(
1302     Tcl_Interp *interp,         /* Tcl interpreter for context. */
1303     Tcl_Parse *parsePtr,        /* Points to a parse structure for the
1304                                  * command. */
1305     Command *cmdPtr,            /* Points to defintion of command being
1306                                  * compiled. */
1307     CompileEnv *envPtr)         /* Holds the resulting instructions. */
1308 {
1309     DefineLineInformation;      /* TIP #280 */
1310     Tcl_Token *tokenPtr, *listTokenPtr;
1311     int idx1, idx2;
1312
1313     if (parsePtr->numWords != 4) {
1314         return TCL_ERROR;
1315     }
1316     listTokenPtr = TokenAfter(parsePtr->tokenPtr);
1317
1318     tokenPtr = TokenAfter(listTokenPtr);
1319     if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
1320             &idx1) != TCL_OK) {
1321         return TCL_ERROR;
1322     }
1323     /*
1324      * Token was an index value, and we treat all "first" indices
1325      * before the list same as the start of the list.
1326      */
1327
1328     tokenPtr = TokenAfter(tokenPtr);
1329     if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
1330             &idx2) != TCL_OK) {
1331         return TCL_ERROR;
1332     }
1333     /*
1334      * Token was an index value, and we treat all "last" indices
1335      * after the list same as the end of the list.
1336      */
1337
1338     /*
1339      * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
1340      * we've not proved that the 'list' argument is really a list. Not that it
1341      * is worth trying to do that given current knowledge.
1342      */
1343
1344     CompileWord(envPtr, listTokenPtr, interp, 1);
1345     TclEmitInstInt4(            INST_LIST_RANGE_IMM, idx1,      envPtr);
1346     TclEmitInt4(                idx2,                           envPtr);
1347     return TCL_OK;
1348 }
1349 \f
1350 /*
1351  *----------------------------------------------------------------------
1352  *
1353  * TclCompileLinsertCmd --
1354  *
1355  *      How to compile the "linsert" command. We only bother with the case
1356  *      where the index is constant.
1357  *
1358  *----------------------------------------------------------------------
1359  */
1360
1361 int
1362 TclCompileLinsertCmd(
1363     Tcl_Interp *interp,         /* Tcl interpreter for context. */
1364     Tcl_Parse *parsePtr,        /* Points to a parse structure for the
1365                                  * command. */
1366     Command *cmdPtr,            /* Points to defintion of command being
1367                                  * compiled. */
1368     CompileEnv *envPtr)         /* Holds the resulting instructions. */
1369 {
1370     DefineLineInformation;      /* TIP #280 */
1371     Tcl_Token *tokenPtr, *listTokenPtr;
1372     int idx, i;
1373
1374     if (parsePtr->numWords < 3) {
1375         return TCL_ERROR;
1376     }
1377     listTokenPtr = TokenAfter(parsePtr->tokenPtr);
1378
1379     /*
1380      * Parse the index. Will only compile if it is constant and not an
1381      * _integer_ less than zero (since we reserve negative indices here for
1382      * end-relative indexing) or an end-based index greater than 'end' itself.
1383      */
1384
1385     tokenPtr = TokenAfter(listTokenPtr);
1386
1387     /*
1388      * NOTE: This command treats all inserts at indices before the list
1389      * the same as inserts at the start of the list, and all inserts
1390      * after the list the same as inserts at the end of the list. We
1391      * make that transformation here so we can use the optimized bytecode
1392      * as much as possible.
1393      */
1394     if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END,
1395             &idx) != TCL_OK) {
1396         return TCL_ERROR;
1397     }
1398
1399     /*
1400      * There are four main cases. If there are no values to insert, this is
1401      * just a confirm-listiness check. If the index is '0', this is a prepend.
1402      * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise,
1403      * this is a splice (== split, insert values as list, concat-3).
1404      */
1405
1406     CompileWord(envPtr, listTokenPtr, interp, 1);
1407     if (parsePtr->numWords == 3) {
1408         TclEmitInstInt4(        INST_LIST_RANGE_IMM, 0,         envPtr);
1409         TclEmitInt4(                    TCL_INDEX_END,          envPtr);
1410         return TCL_OK;
1411     }
1412
1413     for (i=3 ; i<parsePtr->numWords ; i++) {
1414         tokenPtr = TokenAfter(tokenPtr);
1415         CompileWord(envPtr, tokenPtr, interp, i);
1416     }
1417     TclEmitInstInt4(            INST_LIST, i-3,                 envPtr);
1418
1419     if (idx == TCL_INDEX_START) {
1420         TclEmitInstInt4(        INST_REVERSE, 2,                envPtr);
1421         TclEmitOpcode(          INST_LIST_CONCAT,               envPtr);
1422     } else if (idx == TCL_INDEX_END) {
1423         TclEmitOpcode(          INST_LIST_CONCAT,               envPtr);
1424     } else {
1425         /*
1426          * Here we handle two ranges for idx. First when idx > 0, we
1427          * want the first half of the split to end at index idx-1 and
1428          * the second half to start at index idx.
1429          * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
1430          * we want the first half of the split to end at index end-N and
1431          * the second half to start at index end-N+1. We accomplish this
1432          * with a pre-adjustment of the end-N value.
1433          * The root of this is that the commands [lrange] and [linsert]
1434          * differ in their interpretation of the "end" index.
1435          */
1436
1437         if (idx < TCL_INDEX_END) {
1438             idx++;
1439         }
1440         TclEmitInstInt4(        INST_OVER, 1,                   envPtr);
1441         TclEmitInstInt4(        INST_LIST_RANGE_IMM, 0,         envPtr);
1442         TclEmitInt4(                    idx-1,                  envPtr);
1443         TclEmitInstInt4(        INST_REVERSE, 3,                envPtr);
1444         TclEmitInstInt4(        INST_LIST_RANGE_IMM, idx,       envPtr);
1445         TclEmitInt4(                    TCL_INDEX_END,          envPtr);
1446         TclEmitOpcode(          INST_LIST_CONCAT,               envPtr);
1447         TclEmitOpcode(          INST_LIST_CONCAT,               envPtr);
1448     }
1449
1450     return TCL_OK;
1451 }
1452 \f
1453 /*
1454  *----------------------------------------------------------------------
1455  *
1456  * TclCompileLreplaceCmd --
1457  *
1458  *      How to compile the "lreplace" command. We only bother with the case
1459  *      where the indices are constant.
1460  *
1461  *----------------------------------------------------------------------
1462  */
1463
1464 int
1465 TclCompileLreplaceCmd(
1466     Tcl_Interp *interp,         /* Tcl interpreter for context. */
1467     Tcl_Parse *parsePtr,        /* Points to a parse structure for the
1468                                  * command. */
1469     Command *cmdPtr,            /* Points to defintion of command being
1470                                  * compiled. */
1471     CompileEnv *envPtr)         /* Holds the resulting instructions. */
1472 {
1473     DefineLineInformation;      /* TIP #280 */
1474     Tcl_Token *tokenPtr, *listTokenPtr;
1475     int idx1, idx2, i;
1476     int emptyPrefix=1, suffixStart = 0;
1477
1478     if (parsePtr->numWords < 4) {
1479         return TCL_ERROR;
1480     }
1481     listTokenPtr = TokenAfter(parsePtr->tokenPtr);
1482
1483     tokenPtr = TokenAfter(listTokenPtr);
1484     if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
1485             &idx1) != TCL_OK) {
1486         return TCL_ERROR;
1487     }
1488
1489     tokenPtr = TokenAfter(tokenPtr);
1490     if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
1491             &idx2) != TCL_OK) {
1492         return TCL_ERROR;
1493     }
1494
1495     /*
1496      * General structure of the [lreplace] result is
1497      *          prefix replacement suffix
1498      * In a few cases we can predict various parts will be empty and
1499      * take advantage.
1500      *
1501      * The proper suffix begins with the greater of indices idx1 or
1502      * idx2 + 1. If we cannot tell at compile time which is greater,
1503      * we must defer to direct evaluation.
1504      */
1505
1506     if (idx1 == TCL_INDEX_AFTER) {
1507         suffixStart = idx1;
1508     } else if (idx2 == TCL_INDEX_BEFORE) {
1509         suffixStart = idx1;
1510     } else if (idx2 == TCL_INDEX_END) {
1511         suffixStart = TCL_INDEX_AFTER;
1512     } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
1513             || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
1514         suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
1515     } else {
1516         return TCL_ERROR;
1517     }
1518
1519     /* All paths start with computing/pushing the original value. */
1520     CompileWord(envPtr, listTokenPtr, interp, 1);
1521
1522     /*
1523      * Push all the replacement values next so any errors raised in
1524      * creating them get raised first.
1525      */
1526     if (parsePtr->numWords > 4) {
1527         /* Push the replacement arguments */
1528         tokenPtr = TokenAfter(tokenPtr);
1529         for (i=4 ; i<parsePtr->numWords ; i++) {
1530             CompileWord(envPtr, tokenPtr, interp, i);
1531             tokenPtr = TokenAfter(tokenPtr);
1532         }
1533
1534         /* Make a list of them... */
1535         TclEmitInstInt4(        INST_LIST, i - 4,               envPtr);
1536
1537         emptyPrefix = 0;
1538     }
1539
1540     if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
1541         /*
1542          * This is a "no-op". Example: [lreplace {a b c} 2 0]
1543          * We still do a list operation to get list-verification
1544          * and canonicalization side effects.
1545          */
1546         TclEmitInstInt4(        INST_LIST_RANGE_IMM, 0,         envPtr);
1547         TclEmitInt4(                    TCL_INDEX_END,          envPtr);
1548         return TCL_OK;
1549     }
1550
1551     if (idx1 != TCL_INDEX_START) {
1552         /* Prefix may not be empty; generate bytecode to push it */
1553         if (emptyPrefix) {
1554             TclEmitOpcode(      INST_DUP,                       envPtr);
1555         } else {
1556             TclEmitInstInt4(    INST_OVER, 1,                   envPtr);
1557         }
1558         TclEmitInstInt4(        INST_LIST_RANGE_IMM, 0,         envPtr);
1559         TclEmitInt4(                    idx1 - 1,               envPtr);
1560         if (!emptyPrefix) {
1561             TclEmitInstInt4(    INST_REVERSE, 2,                envPtr);
1562             TclEmitOpcode(      INST_LIST_CONCAT,               envPtr);
1563         }
1564         emptyPrefix = 0;
1565     }
1566
1567     if (!emptyPrefix) {
1568         TclEmitInstInt4(        INST_REVERSE, 2,                envPtr);
1569     }
1570
1571     if (suffixStart == TCL_INDEX_AFTER) {
1572         TclEmitOpcode(          INST_POP,                       envPtr);
1573         if (emptyPrefix) {
1574             PushStringLiteral(envPtr, "");
1575         }
1576     } else {
1577         /* Suffix may not be empty; generate bytecode to push it */
1578         TclEmitInstInt4(        INST_LIST_RANGE_IMM, suffixStart, envPtr);
1579         TclEmitInt4(                    TCL_INDEX_END,          envPtr);
1580         if (!emptyPrefix) {
1581             TclEmitOpcode(      INST_LIST_CONCAT,               envPtr);
1582         }
1583     }
1584
1585     return TCL_OK;
1586 }
1587 \f
1588 /*
1589  *----------------------------------------------------------------------
1590  *
1591  * TclCompileLsetCmd --
1592  *
1593  *      Procedure called to compile the "lset" command.
1594  *
1595  * Results:
1596  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1597  *      evaluation to runtime.
1598  *
1599  * Side effects:
1600  *      Instructions are added to envPtr to execute the "lset" command at
1601  *      runtime.
1602  *
1603  * The general template for execution of the "lset" command is:
1604  *      (1) Instructions to push the variable name, unless the variable is
1605  *          local to the stack frame.
1606  *      (2) If the variable is an array element, instructions to push the
1607  *          array element name.
1608  *      (3) Instructions to push each of zero or more "index" arguments to the
1609  *          stack, followed with the "newValue" element.
1610  *      (4) Instructions to duplicate the variable name and/or array element
1611  *          name onto the top of the stack, if either was pushed at steps (1)
1612  *          and (2).
1613  *      (5) The appropriate INST_LOAD_* instruction to place the original
1614  *          value of the list variable at top of stack.
1615  *      (6) At this point, the stack contains:
1616  *              varName? arrayElementName? index1 index2 ... newValue oldList
1617  *          The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
1618  *          according as whether there is exactly one index element (LIST) or
1619  *          either zero or else two or more (FLAT). This instruction removes
1620  *          everything from the stack except for the two names and pushes the
1621  *          new value of the variable.
1622  *      (7) Finally, INST_STORE_* stores the new value in the variable and
1623  *          cleans up the stack.
1624  *
1625  *----------------------------------------------------------------------
1626  */
1627
1628 int
1629 TclCompileLsetCmd(
1630     Tcl_Interp *interp,         /* Tcl interpreter for error reporting. */
1631     Tcl_Parse *parsePtr,        /* Points to a parse structure for the
1632                                  * command. */
1633     Command *cmdPtr,            /* Points to defintion of command being
1634                                  * compiled. */
1635     CompileEnv *envPtr)         /* Holds the resulting instructions. */
1636 {
1637     DefineLineInformation;      /* TIP #280 */
1638     int tempDepth;              /* Depth used for emitting one part of the
1639                                  * code burst. */
1640     Tcl_Token *varTokenPtr;     /* Pointer to the Tcl_Token representing the
1641                                  * parse of the variable name. */
1642     int localIndex;             /* Index of var in local var table. */
1643     int isScalar;               /* Flag == 1 if scalar, 0 if array. */
1644     int i;
1645
1646     /*
1647      * Check argument count.
1648      */
1649
1650     /* TODO: Consider support for compiling expanded args. */
1651     if (parsePtr->numWords < 3) {
1652         /*
1653          * Fail at run time, not in compilation.
1654          */
1655
1656         return TCL_ERROR;
1657     }
1658
1659     /*
1660      * Decide if we can use a frame slot for the var/array name or if we need
1661      * to emit code to compute and push the name at runtime. We use a frame
1662      * slot (entry in the array of local vars) if we are compiling a procedure
1663      * body and if the name is simple text that does not include namespace
1664      * qualifiers.
1665      */
1666
1667     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
1668     PushVarNameWord(interp, varTokenPtr, envPtr, 0,
1669             &localIndex, &isScalar, 1);
1670
1671     /*
1672      * Push the "index" args and the new element value.
1673      */
1674
1675     for (i=2 ; i<parsePtr->numWords ; ++i) {
1676         varTokenPtr = TokenAfter(varTokenPtr);
1677         CompileWord(envPtr, varTokenPtr, interp, i);
1678     }
1679
1680     /*
1681      * Duplicate the variable name if it's been pushed.
1682      */
1683
1684     if (localIndex < 0) {
1685         if (isScalar) {
1686             tempDepth = parsePtr->numWords - 2;
1687         } else {
1688             tempDepth = parsePtr->numWords - 1;
1689         }
1690         TclEmitInstInt4(        INST_OVER, tempDepth,           envPtr);
1691     }
1692
1693     /*
1694      * Duplicate an array index if one's been pushed.
1695      */
1696
1697     if (!isScalar) {
1698         if (localIndex < 0) {
1699             tempDepth = parsePtr->numWords - 1;
1700         } else {
1701             tempDepth = parsePtr->numWords - 2;
1702         }
1703         TclEmitInstInt4(        INST_OVER, tempDepth,           envPtr);
1704     }
1705
1706     /*
1707      * Emit code to load the variable's value.
1708      */
1709
1710     if (isScalar) {
1711         if (localIndex < 0) {
1712             TclEmitOpcode(      INST_LOAD_STK,                  envPtr);
1713         } else {
1714             Emit14Inst(         INST_LOAD_SCALAR, localIndex,   envPtr);
1715         }
1716     } else {
1717         if (localIndex < 0) {
1718             TclEmitOpcode(      INST_LOAD_ARRAY_STK,            envPtr);
1719         } else {
1720             Emit14Inst(         INST_LOAD_ARRAY, localIndex,    envPtr);
1721         }
1722     }
1723
1724     /*
1725      * Emit the correct variety of 'lset' instruction.
1726      */
1727
1728     if (parsePtr->numWords == 4) {
1729         TclEmitOpcode(          INST_LSET_LIST,                 envPtr);
1730     } else {
1731         TclEmitInstInt4(        INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
1732     }
1733
1734     /*
1735      * Emit code to put the value back in the variable.
1736      */
1737
1738     if (isScalar) {
1739         if (localIndex < 0) {
1740             TclEmitOpcode(      INST_STORE_STK,                 envPtr);
1741         } else {
1742             Emit14Inst(         INST_STORE_SCALAR, localIndex,  envPtr);
1743         }
1744     } else {
1745         if (localIndex < 0) {
1746             TclEmitOpcode(      INST_STORE_ARRAY_STK,           envPtr);
1747         } else {
1748             Emit14Inst(         INST_STORE_ARRAY, localIndex,   envPtr);
1749         }
1750     }
1751
1752     return TCL_OK;
1753 }
1754 \f
1755 /*
1756  *----------------------------------------------------------------------
1757  *
1758  * TclCompileNamespace*Cmd --
1759  *
1760  *      Procedures called to compile the "namespace" command; currently, only
1761  *      the subcommands "namespace current" and "namespace upvar" are compiled
1762  *      to bytecodes, and the latter only inside a procedure(-like) context.
1763  *
1764  * Results:
1765  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
1766  *      evaluation to runtime.
1767  *
1768  * Side effects:
1769  *      Instructions are added to envPtr to execute the "namespace upvar"
1770  *      command at runtime.
1771  *
1772  *----------------------------------------------------------------------
1773  */
1774
1775 int
1776 TclCompileNamespaceCurrentCmd(
1777     Tcl_Interp *interp,         /* Used for error reporting. */
1778     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1779                                  * created by Tcl_ParseCommand. */
1780     Command *cmdPtr,            /* Points to defintion of command being
1781                                  * compiled. */
1782     CompileEnv *envPtr)         /* Holds resulting instructions. */
1783 {
1784     /*
1785      * Only compile [namespace current] without arguments.
1786      */
1787
1788     if (parsePtr->numWords != 1) {
1789         return TCL_ERROR;
1790     }
1791
1792     /*
1793      * Not much to do; we compile to a single instruction...
1794      */
1795
1796     TclEmitOpcode(              INST_NS_CURRENT,                envPtr);
1797     return TCL_OK;
1798 }
1799
1800 int
1801 TclCompileNamespaceCodeCmd(
1802     Tcl_Interp *interp,         /* Used for error reporting. */
1803     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1804                                  * created by Tcl_ParseCommand. */
1805     Command *cmdPtr,            /* Points to defintion of command being
1806                                  * compiled. */
1807     CompileEnv *envPtr)         /* Holds resulting instructions. */
1808 {
1809     DefineLineInformation;      /* TIP #280 */
1810     Tcl_Token *tokenPtr;
1811
1812     if (parsePtr->numWords != 2) {
1813         return TCL_ERROR;
1814     }
1815     tokenPtr = TokenAfter(parsePtr->tokenPtr);
1816
1817     /*
1818      * The specification of [namespace code] is rather shocking, in that it is
1819      * supposed to check if the argument is itself the result of [namespace
1820      * code] and not apply itself in that case. Which is excessively cautious,
1821      * but what the test suite checks for.
1822      */
1823
1824     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
1825             && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
1826         /*
1827          * Technically, we could just pass a literal '::namespace inscope '
1828          * term through, but that's something which really shouldn't be
1829          * occurring as something that the user writes so we'll just punt it.
1830          */
1831
1832         return TCL_ERROR;
1833     }
1834
1835     /*
1836      * Now we can compile using the same strategy as [namespace code]'s normal
1837      * implementation does internally. Note that we can't bind the namespace
1838      * name directly here, because TclOO plays complex games with namespaces;
1839      * the value needs to be determined at runtime for safety.
1840      */
1841
1842     PushStringLiteral(envPtr,           "::namespace");
1843     PushStringLiteral(envPtr,           "inscope");
1844     TclEmitOpcode(              INST_NS_CURRENT,        envPtr);
1845     CompileWord(envPtr,         tokenPtr,               interp, 1);
1846     TclEmitInstInt4(            INST_LIST, 4,           envPtr);
1847     return TCL_OK;
1848 }
1849
1850 int
1851 TclCompileNamespaceOriginCmd(
1852     Tcl_Interp *interp,         /* Used for error reporting. */
1853     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1854                                  * created by Tcl_ParseCommand. */
1855     Command *cmdPtr,            /* Points to defintion of command being
1856                                  * compiled. */
1857     CompileEnv *envPtr)         /* Holds resulting instructions. */
1858 {
1859     DefineLineInformation;      /* TIP #280 */
1860     Tcl_Token *tokenPtr;
1861
1862     if (parsePtr->numWords != 2) {
1863         return TCL_ERROR;
1864     }
1865     tokenPtr = TokenAfter(parsePtr->tokenPtr);
1866
1867     CompileWord(envPtr, tokenPtr,                       interp, 1);
1868     TclEmitOpcode(      INST_ORIGIN_COMMAND,            envPtr);
1869     return TCL_OK;
1870 }
1871
1872 int
1873 TclCompileNamespaceQualifiersCmd(
1874     Tcl_Interp *interp,         /* Used for error reporting. */
1875     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1876                                  * created by Tcl_ParseCommand. */
1877     Command *cmdPtr,            /* Points to defintion of command being
1878                                  * compiled. */
1879     CompileEnv *envPtr)         /* Holds resulting instructions. */
1880 {
1881     DefineLineInformation;      /* TIP #280 */
1882     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
1883     int off;
1884
1885     if (parsePtr->numWords != 2) {
1886         return TCL_ERROR;
1887     }
1888
1889     CompileWord(envPtr, tokenPtr, interp, 1);
1890     PushStringLiteral(envPtr, "0");
1891     PushStringLiteral(envPtr, "::");
1892     TclEmitInstInt4(    INST_OVER, 2,                   envPtr);
1893     TclEmitOpcode(      INST_STR_FIND_LAST,             envPtr);
1894     off = CurrentOffset(envPtr);
1895     PushStringLiteral(envPtr, "1");
1896     TclEmitOpcode(      INST_SUB,                       envPtr);
1897     TclEmitInstInt4(    INST_OVER, 2,                   envPtr);
1898     TclEmitInstInt4(    INST_OVER, 1,                   envPtr);
1899     TclEmitOpcode(      INST_STR_INDEX,                 envPtr);
1900     PushStringLiteral(envPtr, ":");
1901     TclEmitOpcode(      INST_STR_EQ,                    envPtr);
1902     off = off - CurrentOffset(envPtr);
1903     TclEmitInstInt1(    INST_JUMP_TRUE1, off,           envPtr);
1904     TclEmitOpcode(      INST_STR_RANGE,                 envPtr);
1905     return TCL_OK;
1906 }
1907
1908 int
1909 TclCompileNamespaceTailCmd(
1910     Tcl_Interp *interp,         /* Used for error reporting. */
1911     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1912                                  * created by Tcl_ParseCommand. */
1913     Command *cmdPtr,            /* Points to defintion of command being
1914                                  * compiled. */
1915     CompileEnv *envPtr)         /* Holds resulting instructions. */
1916 {
1917     DefineLineInformation;      /* TIP #280 */
1918     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
1919     JumpFixup jumpFixup;
1920
1921     if (parsePtr->numWords != 2) {
1922         return TCL_ERROR;
1923     }
1924
1925     /*
1926      * Take care; only add 2 to found index if the string was actually found.
1927      */
1928
1929     CompileWord(envPtr, tokenPtr, interp, 1);
1930     PushStringLiteral(envPtr, "::");
1931     TclEmitInstInt4(    INST_OVER, 1,                   envPtr);
1932     TclEmitOpcode(      INST_STR_FIND_LAST,             envPtr);
1933     TclEmitOpcode(      INST_DUP,                       envPtr);
1934     PushStringLiteral(envPtr, "0");
1935     TclEmitOpcode(      INST_GE,                        envPtr);
1936     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
1937     PushStringLiteral(envPtr, "2");
1938     TclEmitOpcode(      INST_ADD,                       envPtr);
1939     TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
1940     PushStringLiteral(envPtr, "end");
1941     TclEmitOpcode(      INST_STR_RANGE,                 envPtr);
1942     return TCL_OK;
1943 }
1944
1945 int
1946 TclCompileNamespaceUpvarCmd(
1947     Tcl_Interp *interp,         /* Used for error reporting. */
1948     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
1949                                  * created by Tcl_ParseCommand. */
1950     Command *cmdPtr,            /* Points to defintion of command being
1951                                  * compiled. */
1952     CompileEnv *envPtr)         /* Holds resulting instructions. */
1953 {
1954     DefineLineInformation;      /* TIP #280 */
1955     Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
1956     int localIndex, numWords, i;
1957
1958     if (envPtr->procPtr == NULL) {
1959         return TCL_ERROR;
1960     }
1961
1962     /*
1963      * Only compile [namespace upvar ...]: needs an even number of args, >=4
1964      */
1965
1966     numWords = parsePtr->numWords;
1967     if ((numWords % 2) || (numWords < 4)) {
1968         return TCL_ERROR;
1969     }
1970
1971     /*
1972      * Push the namespace
1973      */
1974
1975     tokenPtr = TokenAfter(parsePtr->tokenPtr);
1976     CompileWord(envPtr, tokenPtr, interp, 1);
1977
1978     /*
1979      * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
1980      * local variable, return an error so that the non-compiled command will
1981      * be called at runtime.
1982      */
1983
1984     localTokenPtr = tokenPtr;
1985     for (i=2; i<numWords; i+=2) {
1986         otherTokenPtr = TokenAfter(localTokenPtr);
1987         localTokenPtr = TokenAfter(otherTokenPtr);
1988
1989         CompileWord(envPtr, otherTokenPtr, interp, i);
1990         localIndex = LocalScalarFromToken(localTokenPtr, envPtr);
1991         if (localIndex < 0) {
1992             return TCL_ERROR;
1993         }
1994         TclEmitInstInt4(        INST_NSUPVAR, localIndex,       envPtr);
1995     }
1996
1997     /*
1998      * Pop the namespace, and set the result to empty
1999      */
2000
2001     TclEmitOpcode(              INST_POP,                       envPtr);
2002     PushStringLiteral(envPtr, "");
2003     return TCL_OK;
2004 }
2005
2006 int
2007 TclCompileNamespaceWhichCmd(
2008     Tcl_Interp *interp,         /* Used for error reporting. */
2009     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2010                                  * created by Tcl_ParseCommand. */
2011     Command *cmdPtr,            /* Points to defintion of command being
2012                                  * compiled. */
2013     CompileEnv *envPtr)         /* Holds resulting instructions. */
2014 {
2015     DefineLineInformation;      /* TIP #280 */
2016     Tcl_Token *tokenPtr, *opt;
2017     int idx;
2018
2019     if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
2020         return TCL_ERROR;
2021     }
2022     tokenPtr = TokenAfter(parsePtr->tokenPtr);
2023     idx = 1;
2024
2025     /*
2026      * If there's an option, check that it's "-command". We don't handle
2027      * "-variable" (currently) and anything else is an error.
2028      */
2029
2030     if (parsePtr->numWords == 3) {
2031         if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
2032             return TCL_ERROR;
2033         }
2034         opt = tokenPtr + 1;
2035         if (opt->size < 2 || opt->size > 8
2036                 || strncmp(opt->start, "-command", opt->size) != 0) {
2037             return TCL_ERROR;
2038         }
2039         tokenPtr = TokenAfter(tokenPtr);
2040         idx++;
2041     }
2042
2043     /*
2044      * Issue the bytecode.
2045      */
2046
2047     CompileWord(envPtr,         tokenPtr,               interp, idx);
2048     TclEmitOpcode(              INST_RESOLVE_COMMAND,   envPtr);
2049     return TCL_OK;
2050 }
2051 \f
2052 /*
2053  *----------------------------------------------------------------------
2054  *
2055  * TclCompileRegexpCmd --
2056  *
2057  *      Procedure called to compile the "regexp" command.
2058  *
2059  * Results:
2060  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2061  *      evaluation to runtime.
2062  *
2063  * Side effects:
2064  *      Instructions are added to envPtr to execute the "regexp" command at
2065  *      runtime.
2066  *
2067  *----------------------------------------------------------------------
2068  */
2069
2070 int
2071 TclCompileRegexpCmd(
2072     Tcl_Interp *interp,         /* Tcl interpreter for error reporting. */
2073     Tcl_Parse *parsePtr,        /* Points to a parse structure for the
2074                                  * command. */
2075     Command *cmdPtr,            /* Points to defintion of command being
2076                                  * compiled. */
2077     CompileEnv *envPtr)         /* Holds the resulting instructions. */
2078 {
2079     DefineLineInformation;      /* TIP #280 */
2080     Tcl_Token *varTokenPtr;     /* Pointer to the Tcl_Token representing the
2081                                  * parse of the RE or string. */
2082     int i, len, nocase, exact, sawLast, simple;
2083     const char *str;
2084
2085     /*
2086      * We are only interested in compiling simple regexp cases. Currently
2087      * supported compile cases are:
2088      *   regexp ?-nocase? ?--? staticString $var
2089      *   regexp ?-nocase? ?--? {^staticString$} $var
2090      */
2091
2092     if (parsePtr->numWords < 3) {
2093         return TCL_ERROR;
2094     }
2095
2096     simple = 0;
2097     nocase = 0;
2098     sawLast = 0;
2099     varTokenPtr = parsePtr->tokenPtr;
2100
2101     /*
2102      * We only look for -nocase and -- as options. Everything else gets pushed
2103      * to runtime execution. This is different than regexp's runtime option
2104      * handling, but satisfies our stricter needs.
2105      */
2106
2107     for (i = 1; i < parsePtr->numWords - 2; i++) {
2108         varTokenPtr = TokenAfter(varTokenPtr);
2109         if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
2110             /*
2111              * Not a simple string, so punt to runtime.
2112              */
2113
2114             return TCL_ERROR;
2115         }
2116         str = varTokenPtr[1].start;
2117         len = varTokenPtr[1].size;
2118         if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
2119             sawLast++;
2120             i++;
2121             break;
2122         } else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) {
2123             nocase = 1;
2124         } else {
2125             /*
2126              * Not an option we recognize.
2127              */
2128
2129             return TCL_ERROR;
2130         }
2131     }
2132
2133     if ((parsePtr->numWords - i) != 2) {
2134         /*
2135          * We don't support capturing to variables.
2136          */
2137
2138         return TCL_ERROR;
2139     }
2140
2141     /*
2142      * Get the regexp string. If it is not a simple string or can't be
2143      * converted to a glob pattern, push the word for the INST_REGEXP.
2144      * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
2145      */
2146
2147     varTokenPtr = TokenAfter(varTokenPtr);
2148
2149     if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
2150         Tcl_DString ds;
2151
2152         str = varTokenPtr[1].start;
2153         len = varTokenPtr[1].size;
2154
2155         /*
2156          * If it has a '-', it could be an incorrectly formed regexp command.
2157          */
2158
2159         if ((*str == '-') && !sawLast) {
2160             return TCL_ERROR;
2161         }
2162
2163         if (len == 0) {
2164             /*
2165              * The semantics of regexp are always match on re == "".
2166              */
2167
2168             PushStringLiteral(envPtr, "1");
2169             return TCL_OK;
2170         }
2171
2172         /*
2173          * Attempt to convert pattern to glob.  If successful, push the
2174          * converted pattern as a literal.
2175          */
2176
2177         if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL)
2178                 == TCL_OK) {
2179             simple = 1;
2180             PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
2181             Tcl_DStringFree(&ds);
2182         }
2183     }
2184
2185     if (!simple) {
2186         CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
2187     }
2188
2189     /*
2190      * Push the string arg.
2191      */
2192
2193     varTokenPtr = TokenAfter(varTokenPtr);
2194     CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
2195
2196     if (simple) {
2197         if (exact && !nocase) {
2198             TclEmitOpcode(      INST_STR_EQ,                    envPtr);
2199         } else {
2200             TclEmitInstInt1(    INST_STR_MATCH, nocase,         envPtr);
2201         }
2202     } else {
2203         /*
2204          * Pass correct RE compile flags.  We use only Int1 (8-bit), but
2205          * that handles all the flags we want to pass.
2206          * Don't use TCL_REG_NOSUB as we may have backrefs.
2207          */
2208
2209         int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
2210
2211         TclEmitInstInt1(        INST_REGEXP, cflags,            envPtr);
2212     }
2213
2214     return TCL_OK;
2215 }
2216 \f
2217 /*
2218  *----------------------------------------------------------------------
2219  *
2220  * TclCompileRegsubCmd --
2221  *
2222  *      Procedure called to compile the "regsub" command.
2223  *
2224  * Results:
2225  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2226  *      evaluation to runtime.
2227  *
2228  * Side effects:
2229  *      Instructions are added to envPtr to execute the "regsub" command at
2230  *      runtime.
2231  *
2232  *----------------------------------------------------------------------
2233  */
2234
2235 int
2236 TclCompileRegsubCmd(
2237     Tcl_Interp *interp,         /* Tcl interpreter for error reporting. */
2238     Tcl_Parse *parsePtr,        /* Points to a parse structure for the
2239                                  * command. */
2240     Command *cmdPtr,            /* Points to defintion of command being
2241                                  * compiled. */
2242     CompileEnv *envPtr)         /* Holds the resulting instructions. */
2243 {
2244     /*
2245      * We only compile the case with [regsub -all] where the pattern is both
2246      * known at compile time and simple (i.e., no RE metacharacters). That is,
2247      * the pattern must be translatable into a glob like "*foo*" with no other
2248      * glob metacharacters inside it; there must be some "foo" in there too.
2249      * The substitution string must also be known at compile time and free of
2250      * metacharacters ("\digit" and "&"). Finally, there must not be a
2251      * variable mentioned in the [regsub] to write the result back to (because
2252      * we can't get the count of substitutions that would be the result in
2253      * that case). The key is that these are the conditions under which a
2254      * [string map] could be used instead, in particular a [string map] of the
2255      * form we can compile to bytecode.
2256      *
2257      * In short, we look for:
2258      *
2259      *   regsub -all [--] simpleRE string simpleReplacement
2260      *
2261      * The only optional part is the "--", and no other options are handled.
2262      */
2263
2264     DefineLineInformation;      /* TIP #280 */
2265     Tcl_Token *tokenPtr, *stringTokenPtr;
2266     Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
2267     Tcl_DString pattern;
2268     const char *bytes;
2269     int len, exact, quantified, result = TCL_ERROR;
2270
2271     if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
2272         return TCL_ERROR;
2273     }
2274
2275     /*
2276      * Parse the "-all", which must be the first argument (other options not
2277      * supported, non-"-all" substitution we can't compile).
2278      */
2279
2280     tokenPtr = TokenAfter(parsePtr->tokenPtr);
2281     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
2282             || strncmp(tokenPtr[1].start, "-all", 4)) {
2283         return TCL_ERROR;
2284     }
2285
2286     /*
2287      * Get the pattern into patternObj, checking for "--" in the process.
2288      */
2289
2290     Tcl_DStringInit(&pattern);
2291     tokenPtr = TokenAfter(tokenPtr);
2292     patternObj = Tcl_NewObj();
2293     if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
2294         goto done;
2295     }
2296     if (Tcl_GetString(patternObj)[0] == '-') {
2297         if (strcmp(Tcl_GetString(patternObj), "--") != 0
2298                 || parsePtr->numWords == 5) {
2299             goto done;
2300         }
2301         tokenPtr = TokenAfter(tokenPtr);
2302         Tcl_DecrRefCount(patternObj);
2303         patternObj = Tcl_NewObj();
2304         if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
2305             goto done;
2306         }
2307     } else if (parsePtr->numWords == 6) {
2308         goto done;
2309     }
2310
2311     /*
2312      * Identify the code which produces the string to apply the substitution
2313      * to (stringTokenPtr), and the replacement string (into replacementObj).
2314      */
2315
2316     stringTokenPtr = TokenAfter(tokenPtr);
2317     tokenPtr = TokenAfter(stringTokenPtr);
2318     replacementObj = Tcl_NewObj();
2319     if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
2320         goto done;
2321     }
2322
2323     /*
2324      * Next, higher-level checks. Is the RE a very simple glob? Is the
2325      * replacement "simple"?
2326      */
2327
2328     bytes = Tcl_GetStringFromObj(patternObj, &len);
2329     if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified)
2330             != TCL_OK || exact || quantified) {
2331         goto done;
2332     }
2333     bytes = Tcl_DStringValue(&pattern);
2334     if (*bytes++ != '*') {
2335         goto done;
2336     }
2337     while (1) {
2338         switch (*bytes) {
2339         case '*':
2340             if (bytes[1] == '\0') {
2341                 /*
2342                  * OK, we've proved there are no metacharacters except for the
2343                  * '*' at each end.
2344                  */
2345
2346                 len = Tcl_DStringLength(&pattern) - 2;
2347                 if (len > 0) {
2348                     goto isSimpleGlob;
2349                 }
2350
2351                 /*
2352                  * The pattern is "**"! I believe that should be impossible,
2353                  * but we definitely can't handle that at all.
2354                  */
2355             }
2356         case '\0': case '?': case '[': case '\\':
2357             goto done;
2358         }
2359         bytes++;
2360     }
2361   isSimpleGlob:
2362     for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
2363         switch (*bytes) {
2364         case '\\': case '&':
2365             goto done;
2366         }
2367     }
2368
2369     /*
2370      * Proved the simplicity constraints! Time to issue the code.
2371      */
2372
2373     result = TCL_OK;
2374     bytes = Tcl_DStringValue(&pattern) + 1;
2375     PushLiteral(envPtr, bytes, len);
2376     bytes = Tcl_GetStringFromObj(replacementObj, &len);
2377     PushLiteral(envPtr, bytes, len);
2378     CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
2379     TclEmitOpcode(      INST_STR_MAP,   envPtr);
2380
2381   done:
2382     Tcl_DStringFree(&pattern);
2383     if (patternObj) {
2384         Tcl_DecrRefCount(patternObj);
2385     }
2386     if (replacementObj) {
2387         Tcl_DecrRefCount(replacementObj);
2388     }
2389     return result;
2390 }
2391 \f
2392 /*
2393  *----------------------------------------------------------------------
2394  *
2395  * TclCompileReturnCmd --
2396  *
2397  *      Procedure called to compile the "return" command.
2398  *
2399  * Results:
2400  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2401  *      evaluation to runtime.
2402  *
2403  * Side effects:
2404  *      Instructions are added to envPtr to execute the "return" command at
2405  *      runtime.
2406  *
2407  *----------------------------------------------------------------------
2408  */
2409
2410 int
2411 TclCompileReturnCmd(
2412     Tcl_Interp *interp,         /* Used for error reporting. */
2413     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2414                                  * created by Tcl_ParseCommand. */
2415     Command *cmdPtr,            /* Points to defintion of command being
2416                                  * compiled. */
2417     CompileEnv *envPtr)         /* Holds resulting instructions. */
2418 {
2419     DefineLineInformation;      /* TIP #280 */
2420     /*
2421      * General syntax: [return ?-option value ...? ?result?]
2422      * An even number of words means an explicit result argument is present.
2423      */
2424     int level, code, objc, size, status = TCL_OK;
2425     int numWords = parsePtr->numWords;
2426     int explicitResult = (0 == (numWords % 2));
2427     int numOptionWords = numWords - 1 - explicitResult;
2428     Tcl_Obj *returnOpts, **objv;
2429     Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
2430
2431     /*
2432      * Check for special case which can always be compiled:
2433      *      return -options <opts> <msg>
2434      * Unlike the normal [return] compilation, this version does everything at
2435      * runtime so it can handle arbitrary words and not just literals. Note
2436      * that if INST_RETURN_STK wasn't already needed for something else
2437      * ('finally' clause processing) this piece of code would not be present.
2438      */
2439
2440     if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
2441             && (wordTokenPtr[1].size == 8)
2442             && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
2443         Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
2444         Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
2445
2446         CompileWord(envPtr, optsTokenPtr, interp, 2);
2447         CompileWord(envPtr, msgTokenPtr,  interp, 3);
2448         TclEmitInvoke(envPtr, INST_RETURN_STK);
2449         return TCL_OK;
2450     }
2451
2452     /*
2453      * Allocate some working space.
2454      */
2455
2456     objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
2457
2458     /*
2459      * Scan through the return options. If any are unknown at compile time,
2460      * there is no value in bytecompiling. Save the option values known in an
2461      * objv array for merging into a return options dictionary.
2462      *
2463      * TODO: There is potential for improvement if all option keys are known
2464      * at compile time and all option values relating to '-code' and '-level'
2465      * are known at compile time.
2466      */
2467
2468     for (objc = 0; objc < numOptionWords; objc++) {
2469         objv[objc] = Tcl_NewObj();
2470         Tcl_IncrRefCount(objv[objc]);
2471         if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
2472             /*
2473              * Non-literal, so punt to run-time assembly of the dictionary.
2474              */
2475
2476             for (; objc>=0 ; objc--) {
2477                 TclDecrRefCount(objv[objc]);
2478             }
2479             TclStackFree(interp, objv);
2480             goto issueRuntimeReturn;
2481         }
2482         wordTokenPtr = TokenAfter(wordTokenPtr);
2483     }
2484     status = TclMergeReturnOptions(interp, objc, objv,
2485             &returnOpts, &code, &level);
2486     while (--objc >= 0) {
2487         TclDecrRefCount(objv[objc]);
2488     }
2489     TclStackFree(interp, objv);
2490     if (TCL_ERROR == status) {
2491         /*
2492          * Something was bogus in the return options. Clear the error message,
2493          * and report back to the compiler that this must be interpreted at
2494          * runtime.
2495          */
2496
2497         Tcl_ResetResult(interp);
2498         return TCL_ERROR;
2499     }
2500
2501     /*
2502      * All options are known at compile time, so we're going to bytecompile.
2503      * Emit instructions to push the result on the stack.
2504      */
2505
2506     if (explicitResult) {
2507          CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
2508     } else {
2509         /*
2510          * No explict result argument, so default result is empty string.
2511          */
2512
2513         PushStringLiteral(envPtr, "");
2514     }
2515
2516     /*
2517      * Check for optimization: When [return] is in a proc, and there's no
2518      * enclosing [catch], and there are no return options, then the INST_DONE
2519      * instruction is equivalent, and may be more efficient.
2520      */
2521
2522     if (numOptionWords == 0 && envPtr->procPtr != NULL) {
2523         /*
2524          * We have default return options and we're in a proc ...
2525          */
2526
2527         int index = envPtr->exceptArrayNext - 1;
2528         int enclosingCatch = 0;
2529
2530         while (index >= 0) {
2531             ExceptionRange range = envPtr->exceptArrayPtr[index];
2532
2533             if ((range.type == CATCH_EXCEPTION_RANGE)
2534                     && (range.catchOffset == -1)) {
2535                 enclosingCatch = 1;
2536                 break;
2537             }
2538             index--;
2539         }
2540         if (!enclosingCatch) {
2541             /*
2542              * ... and there is no enclosing catch. Issue the maximally
2543              * efficient exit instruction.
2544              */
2545
2546             Tcl_DecrRefCount(returnOpts);
2547             TclEmitOpcode(INST_DONE, envPtr);
2548             TclAdjustStackDepth(1, envPtr);
2549             return TCL_OK;
2550         }
2551     }
2552
2553     /* Optimize [return -level 0 $x]. */
2554     Tcl_DictObjSize(NULL, returnOpts, &size);
2555     if (size == 0 && level == 0 && code == TCL_OK) {
2556         Tcl_DecrRefCount(returnOpts);
2557         return TCL_OK;
2558     }
2559
2560     /*
2561      * Could not use the optimization, so we push the return options dict, and
2562      * emit the INST_RETURN_IMM instruction with code and level as operands.
2563      */
2564
2565     CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
2566     return TCL_OK;
2567
2568   issueRuntimeReturn:
2569     /*
2570      * Assemble the option dictionary (as a list as that's good enough).
2571      */
2572
2573     wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
2574     for (objc=1 ; objc<=numOptionWords ; objc++) {
2575         CompileWord(envPtr, wordTokenPtr, interp, objc);
2576         wordTokenPtr = TokenAfter(wordTokenPtr);
2577     }
2578     TclEmitInstInt4(INST_LIST, numOptionWords, envPtr);
2579
2580     /*
2581      * Push the result.
2582      */
2583
2584     if (explicitResult) {
2585         CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
2586     } else {
2587         PushStringLiteral(envPtr, "");
2588     }
2589
2590     /*
2591      * Issue the RETURN itself.
2592      */
2593
2594     TclEmitInvoke(envPtr, INST_RETURN_STK);
2595     return TCL_OK;
2596 }
2597
2598 static void
2599 CompileReturnInternal(
2600     CompileEnv *envPtr,
2601     unsigned char op,
2602     int code,
2603     int level,
2604     Tcl_Obj *returnOpts)
2605 {
2606     if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) {
2607         ExceptionRange *rangePtr;
2608         ExceptionAux *exceptAux;
2609
2610         rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux);
2611         if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
2612             TclCleanupStackForBreakContinue(envPtr, exceptAux);
2613             if (code == TCL_BREAK) {
2614                 TclAddLoopBreakFixup(envPtr, exceptAux);
2615             } else {
2616                 TclAddLoopContinueFixup(envPtr, exceptAux);
2617             }
2618             Tcl_DecrRefCount(returnOpts);
2619             return;
2620         }
2621     }
2622
2623     TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
2624     TclEmitInstInt4(op, code, envPtr);
2625     TclEmitInt4(level, envPtr);
2626 }
2627
2628 void
2629 TclCompileSyntaxError(
2630     Tcl_Interp *interp,
2631     CompileEnv *envPtr)
2632 {
2633     Tcl_Obj *msg = Tcl_GetObjResult(interp);
2634     int numBytes;
2635     const char *bytes = TclGetStringFromObj(msg, &numBytes);
2636
2637     TclErrorStackResetIf(interp, bytes, numBytes);
2638     TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
2639     CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
2640             TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
2641     Tcl_ResetResult(interp);
2642 }
2643 \f
2644 /*
2645  *----------------------------------------------------------------------
2646  *
2647  * TclCompileUpvarCmd --
2648  *
2649  *      Procedure called to compile the "upvar" command.
2650  *
2651  * Results:
2652  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2653  *      evaluation to runtime.
2654  *
2655  * Side effects:
2656  *      Instructions are added to envPtr to execute the "upvar" command at
2657  *      runtime.
2658  *
2659  *----------------------------------------------------------------------
2660  */
2661
2662 int
2663 TclCompileUpvarCmd(
2664     Tcl_Interp *interp,         /* Used for error reporting. */
2665     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2666                                  * created by Tcl_ParseCommand. */
2667     Command *cmdPtr,            /* Points to defintion of command being
2668                                  * compiled. */
2669     CompileEnv *envPtr)         /* Holds resulting instructions. */
2670 {
2671     DefineLineInformation;      /* TIP #280 */
2672     Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
2673     int localIndex, numWords, i;
2674     Tcl_Obj *objPtr;
2675
2676     if (envPtr->procPtr == NULL) {
2677         return TCL_ERROR;
2678     }
2679
2680     numWords = parsePtr->numWords;
2681     if (numWords < 3) {
2682         return TCL_ERROR;
2683     }
2684
2685     /*
2686      * Push the frame index if it is known at compile time
2687      */
2688
2689     objPtr = Tcl_NewObj();
2690     tokenPtr = TokenAfter(parsePtr->tokenPtr);
2691     if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
2692         CallFrame *framePtr;
2693         const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
2694
2695         /*
2696          * Attempt to convert to a level reference. Note that TclObjGetFrame
2697          * only changes the obj type when a conversion was successful.
2698          */
2699
2700         TclObjGetFrame(interp, objPtr, &framePtr);
2701         newTypePtr = objPtr->typePtr;
2702         Tcl_DecrRefCount(objPtr);
2703
2704         if (newTypePtr != typePtr) {
2705             if (numWords%2) {
2706                 return TCL_ERROR;
2707             }
2708             /* TODO: Push the known value instead? */
2709             CompileWord(envPtr, tokenPtr, interp, 1);
2710             otherTokenPtr = TokenAfter(tokenPtr);
2711             i = 2;
2712         } else {
2713             if (!(numWords%2)) {
2714                 return TCL_ERROR;
2715             }
2716             PushStringLiteral(envPtr, "1");
2717             otherTokenPtr = tokenPtr;
2718             i = 1;
2719         }
2720     } else {
2721         Tcl_DecrRefCount(objPtr);
2722         return TCL_ERROR;
2723     }
2724
2725     /*
2726      * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
2727      * local variable, return an error so that the non-compiled command will
2728      * be called at runtime.
2729      */
2730
2731     for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
2732         localTokenPtr = TokenAfter(otherTokenPtr);
2733
2734         CompileWord(envPtr, otherTokenPtr, interp, i);
2735         localIndex = LocalScalarFromToken(localTokenPtr, envPtr);
2736         if (localIndex < 0) {
2737             return TCL_ERROR;
2738         }
2739         TclEmitInstInt4(        INST_UPVAR, localIndex,         envPtr);
2740     }
2741
2742     /*
2743      * Pop the frame index, and set the result to empty
2744      */
2745
2746     TclEmitOpcode(              INST_POP,                       envPtr);
2747     PushStringLiteral(envPtr, "");
2748     return TCL_OK;
2749 }
2750 \f
2751 /*
2752  *----------------------------------------------------------------------
2753  *
2754  * TclCompileVariableCmd --
2755  *
2756  *      Procedure called to compile the "variable" command.
2757  *
2758  * Results:
2759  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2760  *      evaluation to runtime.
2761  *
2762  * Side effects:
2763  *      Instructions are added to envPtr to execute the "variable" command at
2764  *      runtime.
2765  *
2766  *----------------------------------------------------------------------
2767  */
2768
2769 int
2770 TclCompileVariableCmd(
2771     Tcl_Interp *interp,         /* Used for error reporting. */
2772     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2773                                  * created by Tcl_ParseCommand. */
2774     Command *cmdPtr,            /* Points to defintion of command being
2775                                  * compiled. */
2776     CompileEnv *envPtr)         /* Holds resulting instructions. */
2777 {
2778     DefineLineInformation;      /* TIP #280 */
2779     Tcl_Token *varTokenPtr, *valueTokenPtr;
2780     int localIndex, numWords, i;
2781
2782     numWords = parsePtr->numWords;
2783     if (numWords < 2) {
2784         return TCL_ERROR;
2785     }
2786
2787     /*
2788      * Bail out if not compiling a proc body
2789      */
2790
2791     if (envPtr->procPtr == NULL) {
2792         return TCL_ERROR;
2793     }
2794
2795     /*
2796      * Loop over the (var, value) pairs.
2797      */
2798
2799     valueTokenPtr = parsePtr->tokenPtr;
2800     for (i=1; i<numWords; i+=2) {
2801         varTokenPtr = TokenAfter(valueTokenPtr);
2802         valueTokenPtr = TokenAfter(varTokenPtr);
2803
2804         localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
2805
2806         if (localIndex < 0) {
2807             return TCL_ERROR;
2808         }
2809
2810         /* TODO: Consider what value can pass through the
2811          * IndexTailVarIfKnown() screen.  Full CompileWord()
2812          * likely does not apply here.  Push known value instead. */
2813         CompileWord(envPtr, varTokenPtr, interp, i);
2814         TclEmitInstInt4(        INST_VARIABLE, localIndex,      envPtr);
2815
2816         if (i+1 < numWords) {
2817             /*
2818              * A value has been given: set the variable, pop the value
2819              */
2820
2821             CompileWord(envPtr, valueTokenPtr, interp, i+1);
2822             Emit14Inst(         INST_STORE_SCALAR, localIndex,  envPtr);
2823             TclEmitOpcode(      INST_POP,                       envPtr);
2824         }
2825     }
2826
2827     /*
2828      * Set the result to empty
2829      */
2830
2831     PushStringLiteral(envPtr, "");
2832     return TCL_OK;
2833 }
2834 \f
2835 /*
2836  *----------------------------------------------------------------------
2837  *
2838  * IndexTailVarIfKnown --
2839  *
2840  *      Procedure used in compiling [global] and [variable] commands. It
2841  *      inspects the variable name described by varTokenPtr and, if the tail
2842  *      is known at compile time, defines a corresponding local variable.
2843  *
2844  * Results:
2845  *      Returns the variable's index in the table of compiled locals if the
2846  *      tail is known at compile time, or -1 otherwise.
2847  *
2848  * Side effects:
2849  *      None.
2850  *
2851  *----------------------------------------------------------------------
2852  */
2853
2854 static int
2855 IndexTailVarIfKnown(
2856     Tcl_Interp *interp,
2857     Tcl_Token *varTokenPtr,     /* Token representing the variable name */
2858     CompileEnv *envPtr)         /* Holds resulting instructions. */
2859 {
2860     Tcl_Obj *tailPtr;
2861     const char *tailName, *p;
2862     int len, n = varTokenPtr->numComponents;
2863     Tcl_Token *lastTokenPtr;
2864     int full, localIndex;
2865
2866     /*
2867      * Determine if the tail is (a) known at compile time, and (b) not an
2868      * array element. Should any of these fail, return an error so that the
2869      * non-compiled command will be called at runtime.
2870      *
2871      * In order for the tail to be known at compile time, the last token in
2872      * the word has to be constant and contain "::" if it is not the only one.
2873      */
2874
2875     if (!EnvHasLVT(envPtr)) {
2876         return -1;
2877     }
2878
2879     TclNewObj(tailPtr);
2880     if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
2881         full = 1;
2882         lastTokenPtr = varTokenPtr;
2883     } else {
2884         full = 0;
2885         lastTokenPtr = varTokenPtr + n;
2886
2887         if (lastTokenPtr->type != TCL_TOKEN_TEXT) {
2888             Tcl_DecrRefCount(tailPtr);
2889             return -1;
2890         }
2891         Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size);
2892     }
2893
2894     tailName = TclGetStringFromObj(tailPtr, &len);
2895
2896     if (len) {
2897         if (*(tailName+len-1) == ')') {
2898             /*
2899              * Possible array: bail out
2900              */
2901
2902             Tcl_DecrRefCount(tailPtr);
2903             return -1;
2904         }
2905
2906         /*
2907          * Get the tail: immediately after the last '::'
2908          */
2909
2910         for (p = tailName + len -1; p > tailName; p--) {
2911             if ((*p == ':') && (*(p-1) == ':')) {
2912                 p++;
2913                 break;
2914             }
2915         }
2916         if (!full && (p == tailName)) {
2917             /*
2918              * No :: in the last component.
2919              */
2920
2921             Tcl_DecrRefCount(tailPtr);
2922             return -1;
2923         }
2924         len -= p - tailName;
2925         tailName = p;
2926     }
2927
2928     localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
2929     Tcl_DecrRefCount(tailPtr);
2930     return localIndex;
2931 }
2932 \f
2933 /*
2934  * ----------------------------------------------------------------------
2935  *
2936  * TclCompileObjectNextCmd, TclCompileObjectSelfCmd --
2937  *
2938  *      Compilations of the TclOO utility commands [next] and [self].
2939  *
2940  * ----------------------------------------------------------------------
2941  */
2942
2943 int
2944 TclCompileObjectNextCmd(
2945     Tcl_Interp *interp,         /* Used for error reporting. */
2946     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2947                                  * created by Tcl_ParseCommand. */
2948     Command *cmdPtr,            /* Points to defintion of command being
2949                                  * compiled. */
2950     CompileEnv *envPtr)         /* Holds resulting instructions. */
2951 {
2952     DefineLineInformation;      /* TIP #280 */
2953     Tcl_Token *tokenPtr = parsePtr->tokenPtr;
2954     int i;
2955
2956     if (parsePtr->numWords > 255) {
2957         return TCL_ERROR;
2958     }
2959
2960     for (i=0 ; i<parsePtr->numWords ; i++) {
2961         CompileWord(envPtr, tokenPtr, interp, i);
2962         tokenPtr = TokenAfter(tokenPtr);
2963     }
2964     TclEmitInstInt1(    INST_TCLOO_NEXT, i,             envPtr);
2965     return TCL_OK;
2966 }
2967
2968 int
2969 TclCompileObjectNextToCmd(
2970     Tcl_Interp *interp,         /* Used for error reporting. */
2971     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2972                                  * created by Tcl_ParseCommand. */
2973     Command *cmdPtr,            /* Points to defintion of command being
2974                                  * compiled. */
2975     CompileEnv *envPtr)         /* Holds resulting instructions. */
2976 {
2977     DefineLineInformation;      /* TIP #280 */
2978     Tcl_Token *tokenPtr = parsePtr->tokenPtr;
2979     int i;
2980
2981     if (parsePtr->numWords < 2 || parsePtr->numWords > 255) {
2982         return TCL_ERROR;
2983     }
2984
2985     for (i=0 ; i<parsePtr->numWords ; i++) {
2986         CompileWord(envPtr, tokenPtr, interp, i);
2987         tokenPtr = TokenAfter(tokenPtr);
2988     }
2989     TclEmitInstInt1(    INST_TCLOO_NEXT_CLASS, i,       envPtr);
2990     return TCL_OK;
2991 }
2992
2993 int
2994 TclCompileObjectSelfCmd(
2995     Tcl_Interp *interp,         /* Used for error reporting. */
2996     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2997                                  * created by Tcl_ParseCommand. */
2998     Command *cmdPtr,            /* Points to defintion of command being
2999                                  * compiled. */
3000     CompileEnv *envPtr)         /* Holds resulting instructions. */
3001 {
3002     /*
3003      * We only handle [self] and [self object] (which is the same operation).
3004      * These are the only very common operations on [self] for which
3005      * bytecoding is at all reasonable.
3006      */
3007
3008     if (parsePtr->numWords == 1) {
3009         goto compileSelfObject;
3010     } else if (parsePtr->numWords == 2) {
3011         Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
3012
3013         if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) {
3014             return TCL_ERROR;
3015         }
3016
3017         subcmd = tokenPtr + 1;
3018         if (strncmp(subcmd->start, "object", subcmd->size) == 0) {
3019             goto compileSelfObject;
3020         } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) {
3021             goto compileSelfNamespace;
3022         }
3023     }
3024
3025     /*
3026      * Can't compile; handle with runtime call.
3027      */
3028
3029     return TCL_ERROR;
3030
3031   compileSelfObject:
3032
3033     /*
3034      * This delegates the entire problem to a single opcode.
3035      */
3036
3037     TclEmitOpcode(              INST_TCLOO_SELF,                envPtr);
3038     return TCL_OK;
3039
3040   compileSelfNamespace:
3041
3042     /*
3043      * This is formally only correct with TclOO methods as they are currently
3044      * implemented; it assumes that the current namespace is invariably when a
3045      * TclOO context is present is the object's namespace, and that's
3046      * technically only something that's a matter of current policy. But it
3047      * avoids creating another opcode, so that's all good!
3048      */
3049
3050     TclEmitOpcode(              INST_TCLOO_SELF,                envPtr);
3051     TclEmitOpcode(              INST_POP,                       envPtr);
3052     TclEmitOpcode(              INST_NS_CURRENT,                envPtr);
3053     return TCL_OK;
3054 }
3055 \f
3056 /*
3057  * Local Variables:
3058  * mode: c
3059  * c-basic-offset: 4
3060  * fill-column: 78
3061  * End:
3062  */