/* * tclCompCmdsGR.c -- * * This file contains compilation procedures that compile various Tcl * commands (beginning with the letters 'g' through 'r') into a sequence * of instructions ("bytecodes"). * * Copyright © 1997-1998 Sun Microsystems, Inc. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2002 ActiveState Corporation. * Copyright © 2004-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #include /* * Prototypes for procedures defined later in this file: */ static void CompileReturnInternal(CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); /* *---------------------------------------------------------------------- * * TclGetIndexFromToken -- * * Parse a token to determine if an index value is known at * compile time. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: * When TCL_OK is returned, the encoded index value is written * to *index. * *---------------------------------------------------------------------- */ int TclGetIndexFromToken( Tcl_Token *tokenPtr, size_t before, size_t after, int *indexPtr) { Tcl_Obj *tmpObj; int result = TCL_ERROR; TclNewObj(tmpObj); if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); } Tcl_DecrRefCount(tmpObj); return result; } /* *---------------------------------------------------------------------- * * TclCompileGlobalCmd -- * * Procedure called to compile the "global" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "global" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileGlobalCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; int localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } /* * 'global' has no effect outside of proc bodies; handle that at runtime */ if (envPtr->procPtr == NULL) { return TCL_ERROR; } /* * Push the namespace */ PushStringLiteral(envPtr, "::"); /* * Loop over the variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i=1; itokenPtr; wordIdx = 0; numWords = parsePtr->numWords; for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); } TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); code = TCL_OK; /* * Each iteration of this loop compiles one "if expr ?then? body" or * "elseif expr ?then? body" clause. */ tokenPtr = parsePtr->tokenPtr; wordIdx = 0; while (wordIdx < numWords) { /* * Stop looping if the token isn't "if" or "elseif". */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((tokenPtr == parsePtr->tokenPtr) || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; } else { break; } if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } /* * Compile the test expression then emit the conditional jump around * the "then" part. */ testTokenPtr = tokenPtr; if (realCond) { /* * Find out if the condition is a constant. */ Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); Tcl_IncrRefCount(boolObj); code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); TclDecrRefCount(boolObj); if (code == TCL_OK) { /* * A static condition. */ realCond = 0; if (!boolVal) { compileScripts = 0; } } else { SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, jumpFalseFixupArray.fixup + jumpIndex); } code = TCL_OK; } /* * Skip over the optional "then" before the then clause. */ tokenPtr = TokenAfter(testTokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } } } /* * Compile the "then" command body. */ if (compileScripts) { BODY(tokenPtr, wordIdx); } if (realCond) { /* * Jump to the end of the "if" command. Both jumpFalseFixupArray * and jumpEndFixupArray are indexed by "jumpIndex". */ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { TclExpandJumpFixupArray(&jumpEndFixupArray); } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, jumpEndFixupArray.fixup + jumpIndex); /* * Fix the target of the jumpFalse after the test. Generate a 4 * byte jump if the distance is > 120 bytes. This is conservative, * and ensures that we won't have to replace this jump if we later * also need to replace the proceeding jump to the end of the "if" * with a 4 byte jump. */ TclAdjustStackDepth(-1, envPtr); if (TclFixupForwardJumpToHere(envPtr, jumpFalseFixupArray.fixup + jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. */ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; } } else if (boolVal) { /* * We were processing an "if 1 {...}"; stop compiling scripts. */ compileScripts = 0; } else { /* * We were processing an "if 0 {...}"; reset so that the rest * (elseif, else) is compiled correctly. */ realCond = 1; compileScripts = 1; } tokenPtr = TokenAfter(tokenPtr); wordIdx++; } /* * Check for the optional else clause. Do not compile anything if this was * an "if 1 {...}" case. */ if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { /* * There is an else clause. Skip over the optional "else" word. */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } } if (compileScripts) { /* * Compile the else command body. */ BODY(tokenPtr, wordIdx); } /* * Make sure there are no words after the else clause. */ wordIdx++; if (wordIdx < numWords) { code = TCL_ERROR; goto done; } } else { /* * No else clause: the "if" command's result is an empty string. */ if (compileScripts) { PushStringLiteral(envPtr, ""); } } /* * Fix the unconditional jumps to the end of the "if" command. */ for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ if (TclFixupForwardJumpToHere(envPtr, jumpEndFixupArray.fixup + jumpIndex, 127)) { /* * Adjust the immediately preceding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. */ unsigned char *ifFalsePc = envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; unsigned char opCode = *ifFalsePc; if (opCode == INST_JUMP_FALSE1) { jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else if (opCode == INST_JUMP_FALSE4) { jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); } } } /* * Free the jumpFixupArray array if malloc'ed storage was used. */ done: TclFreeJumpFixupArray(&jumpFalseFixupArray); TclFreeJumpFixupArray(&jumpEndFixupArray); return code; } /* *---------------------------------------------------------------------- * * TclCompileIncrCmd -- * * Procedure called to compile the "incr" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "incr" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileIncrCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *incrTokenPtr; int isScalar, localIndex, haveImmValue; Tcl_WideInt immValue; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, &localIndex, &isScalar, 1); /* * If an increment is given, push it, but see first if it's a small * integer. */ haveImmValue = 0; immValue = 1; if (parsePtr->numWords == 3) { incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; size_t numBytes = incrTokenPtr[1].size; int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); Tcl_IncrRefCount(intObj); code = TclGetWideIntFromObj(NULL, intObj, &immValue); if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } TclDecrRefCount(intObj); if (!haveImmValue) { PushLiteral(envPtr, word, numBytes); } } else { SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ haveImmValue = 1; } /* * Emit the instruction to increment the variable. */ if (isScalar) { /* Simple scalar variable. */ if (localIndex >= 0) { if (haveImmValue) { TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); } } else { if (haveImmValue) { TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); } else { TclEmitOpcode( INST_INCR_STK, envPtr); } } } else { /* Simple array variable. */ if (localIndex >= 0) { if (haveImmValue) { TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); } } else { if (haveImmValue) { TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); } else { TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); } } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileInfo*Cmd -- * * Procedures called to compile "info" subcommands. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "info" subcommand at * runtime. * *---------------------------------------------------------------------- */ int TclCompileInfoCommandsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; Tcl_Obj *objPtr; const char *bytes; /* * We require one compile-time known argument for the case we can compile. */ if (parsePtr->numWords == 1) { return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; } bytes = TclGetString(objPtr); /* * We require that the argument start with "::" and not have any of "*\[?" * in it. (Theoretically, we should look in only the final component, but * the difference is so slight given current naming practices.) */ if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { goto notCompilable; } Tcl_DecrRefCount(objPtr); /* * Confirmed as a literal that will not frighten the horses. Compile. * The result must be made into a list. */ /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_STR_LEN, envPtr); TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); TclEmitInstInt4( INST_LIST, 1, envPtr); return TCL_OK; notCompilable: Tcl_DecrRefCount(objPtr); return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int TclCompileInfoCoroutineCmd( TCL_UNUSED(Tcl_Interp *), Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { /* * Only compile [info coroutine] without arguments. */ if (parsePtr->numWords != 1) { return TCL_ERROR; } /* * Not much to do; we compile to a single instruction... */ TclEmitOpcode( INST_COROUTINE_NAME, envPtr); return TCL_OK; } int TclCompileInfoExistsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int isScalar, localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1); /* * Emit instruction to check the variable for existence. */ if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_EXIST_STK, envPtr); } else { TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); } else { TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); } } return TCL_OK; } int TclCompileInfoLevelCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { /* * Only compile [info level] without arguments or with a single argument. */ if (parsePtr->numWords == 1) { /* * Not much to do; we compile to a single instruction... */ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); } else if (parsePtr->numWords != 2) { return TCL_ERROR; } else { DefineLineInformation; /* TIP #280 */ /* * Compile the argument, then add the instruction to convert it into a * list of arguments. */ CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } return TCL_OK; } int TclCompileInfoObjectClassCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); if (parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_TCLOO_CLASS, envPtr); return TCL_OK; } int TclCompileInfoObjectIsACmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); /* * We only handle [info object isa object ]. The first three * words are compressed to a single token by the ensemble compilation * engine. */ if (parsePtr->numWords != 3) { return TCL_ERROR; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); /* * Issue the code. */ CompileWord(envPtr, tokenPtr, interp, 2); TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); return TCL_OK; } int TclCompileInfoObjectNamespaceCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); if (parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_TCLOO_NS, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lappend" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLappendCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; int isScalar, localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } if (numWords != 3 || envPtr->procPtr == NULL) { goto lappendMultiple; } /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include * namespace qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); /* * If we are doing an assignment, push the new value. In the no values * case, create an empty object. */ if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } /* * Emit instructions to set/get the variable. */ /* * The *_STK opcodes should be refactored to make better use of existing * LOAD/STORE instructions. */ if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_STK, envPtr); } else { Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); } else { Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); } } return TCL_OK; lappendMultiple: varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); } else { TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr); } else { TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLassignCmd -- * * Procedure called to compile the "lassign" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lassign" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLassignCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int isScalar, localIndex, numWords, idx; numWords = parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime. */ if (numWords < 3) { return TCL_ERROR; } /* * Generate code to push list being taken apart by [lassign]. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); /* * Generate code to assign values from the list to variables. */ for (idx=0 ; idx= 0) { TclEmitOpcode( INST_DUP, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } else { TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); TclEmitOpcode( INST_STORE_STK, envPtr); TclEmitOpcode( INST_POP, envPtr); } } else { if (localIndex >= 0) { TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } else { TclEmitInstInt4(INST_OVER, 2, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); TclEmitOpcode( INST_POP, envPtr); } } } /* * Generate code to leave the rest of the list on the stack. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLindexCmd -- * * Procedure called to compile the "lindex" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lindex" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLindexCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *idxTokenPtr, *valTokenPtr; int i, idx, numWords = parsePtr->numWords; /* * Quit if not enough args. */ /* TODO: Consider support for compiling expanded args. */ if (numWords <= 1) { return TCL_ERROR; } valTokenPtr = TokenAfter(parsePtr->tokenPtr); if (numWords != 3) { goto emitComplexLindex; } idxTokenPtr = TokenAfter(valTokenPtr); if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_NONE, TCL_INDEX_NONE, &idx) == TCL_OK) { /* * The idxTokenPtr parsed as a valid index value and was * encoded as expected by INST_LIST_INDEX_IMM. * * NOTE: that we rely on indexing before a list producing the * same result as indexing after a list. */ CompileWord(envPtr, valTokenPtr, interp, 1); TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); return TCL_OK; } /* * If the value was not known at compile time, the conversion failed or * the value was negative, we just keep on going with the more complex * compilation. */ /* * Push the operands onto the stack. */ emitComplexLindex: for (i=1 ; inumWords == 1) { /* * [list] without arguments just pushes an empty object. */ PushStringLiteral(envPtr, ""); return TCL_OK; } /* * Test if all arguments are compile-time known. If they are, we can * implement with a simple push. */ numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { TclNewObj(objPtr); if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); } else { Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(listObj); listObj = NULL; } valueTokenPtr = TokenAfter(valueTokenPtr); } if (listObj != NULL) { TclEmitPush(TclAddLiteralObj(envPtr, listObj, NULL), envPtr); return TCL_OK; } /* * Push the all values onto the stack. */ numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); concat = build = 0; for (i = 1; i < numWords; i++) { if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { TclEmitInstInt4( INST_LIST, build, envPtr); if (concat) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } build = 0; concat = 1; } CompileWord(envPtr, valueTokenPtr, interp, i); if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { if (concat) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { concat = 1; } } else { build++; } valueTokenPtr = TokenAfter(valueTokenPtr); } if (build > 0) { TclEmitInstInt4( INST_LIST, build, envPtr); if (concat) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } } /* * If there was just one expanded word, we must ensure that it is a list * at this point. We use an [lrange ... 0 end] for this (instead of * [llength], as with literals) as we must drop any string representation * that might be hanging around. */ if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( (int)TCL_INDEX_END, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLlengthCmd -- * * Procedure called to compile the "llength" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "llength" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLlengthCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_LIST_LENGTH, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLrangeCmd -- * * How to compile the "lrange" command. We only bother because we needed * the opcode anyway for "lassign". * *---------------------------------------------------------------------- */ int TclCompileLrangeCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *listTokenPtr; int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) { return TCL_ERROR; } /* * Token was an index value, and we treat all "first" indices * before the list same as the start of the list. */ tokenPtr = TokenAfter(tokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, &idx2) != TCL_OK) { return TCL_ERROR; } /* * Token was an index value, and we treat all "last" indices * after the list same as the end of the list. */ /* * Issue instructions. It's not safe to skip doing the LIST_RANGE, as * we've not proved that the 'list' argument is really a list. Not that it * is worth trying to do that given current knowledge. */ CompileWord(envPtr, listTokenPtr, interp, 1); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); TclEmitInt4( idx2, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLinsertCmd -- * * How to compile the "linsert" command. We only bother with the case * where the index is constant. * *---------------------------------------------------------------------- */ int TclCompileLinsertCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i; if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } /* Push list, insertion index onto the stack */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); /* Push new elements to be inserted */ for (i=3 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } /* First operand is count of arguments */ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); /* * Second operand is bitmask * TCL_LREPLACE4_END_IS_LAST - end refers to last element * TCL_LREPLACE4_SINGLE_INDEX - second index is not present * indicating this is a pure insert */ TclEmitInt1(TCL_LREPLACE4_SINGLE_INDEX, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLreplaceCmd -- * * How to compile the "lreplace" command. We only bother with the case * where the indices are constant. * *---------------------------------------------------------------------- */ int TclCompileLreplaceCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i; if (parsePtr->numWords < 4) { return TCL_ERROR; } /* Push list, first, last onto the stack */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); /* Push new elements to be inserted */ for (i=4 ; i< (int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } /* First operand is count of arguments */ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); /* * Second operand is bitmask * TCL_LREPLACE4_END_IS_LAST - end refers to last element */ TclEmitInt1(TCL_LREPLACE4_END_IS_LAST, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLsetCmd -- * * Procedure called to compile the "lset" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lset" command at * runtime. * * The general template for execution of the "lset" command is: * (1) Instructions to push the variable name, unless the variable is * local to the stack frame. * (2) If the variable is an array element, instructions to push the * array element name. * (3) Instructions to push each of zero or more "index" arguments to the * stack, followed with the "newValue" element. * (4) Instructions to duplicate the variable name and/or array element * name onto the top of the stack, if either was pushed at steps (1) * and (2). * (5) The appropriate INST_LOAD_* instruction to place the original * value of the list variable at top of stack. * (6) At this point, the stack contains: * varName? arrayElementName? index1 index2 ... newValue oldList * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST * according as whether there is exactly one index element (LIST) or * either zero or else two or more (FLAT). This instruction removes * everything from the stack except for the two names and pushes the * new value of the variable. * (7) Finally, INST_STORE_* stores the new value in the variable and * cleans up the stack. * *---------------------------------------------------------------------- */ int TclCompileLsetCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ int tempDepth; /* Depth used for emitting one part of the * code burst. */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the variable name. */ int localIndex; /* Index of var in local var table. */ int isScalar; /* Flag == 1 if scalar, 0 if array. */ int i; /* * Check argument count. */ /* TODO: Consider support for compiling expanded args. */ if ((int)parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. */ return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); /* * Push the "index" args and the new element value. */ for (i=2 ; i<(int)parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, i); } /* * Duplicate the variable name if it's been pushed. */ if (localIndex < 0) { if (isScalar) { tempDepth = parsePtr->numWords - 2; } else { tempDepth = parsePtr->numWords - 1; } TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } /* * Duplicate an array index if one's been pushed. */ if (!isScalar) { if (localIndex < 0) { tempDepth = parsePtr->numWords - 1; } else { tempDepth = parsePtr->numWords - 2; } TclEmitInstInt4( INST_OVER, tempDepth, envPtr); } /* * Emit code to load the variable's value. */ if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_LOAD_STK, envPtr); } else { Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); } else { Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); } } /* * Emit the correct variety of 'lset' instruction. */ if (parsePtr->numWords == 4) { TclEmitOpcode( INST_LSET_LIST, envPtr); } else { TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); } /* * Emit code to put the value back in the variable. */ if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_STORE_STK, envPtr); } else { Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); } else { Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileNamespace*Cmd -- * * Procedures called to compile the "namespace" command; currently, only * the subcommands "namespace current" and "namespace upvar" are compiled * to bytecodes, and the latter only inside a procedure(-like) context. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "namespace upvar" * command at runtime. * *---------------------------------------------------------------------- */ int TclCompileNamespaceCurrentCmd( TCL_UNUSED(Tcl_Interp *), Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { /* * Only compile [namespace current] without arguments. */ if (parsePtr->numWords != 1) { return TCL_ERROR; } /* * Not much to do; we compile to a single instruction... */ TclEmitOpcode( INST_NS_CURRENT, envPtr); return TCL_OK; } int TclCompileNamespaceCodeCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); /* * The specification of [namespace code] is rather shocking, in that it is * supposed to check if the argument is itself the result of [namespace * code] and not apply itself in that case. Which is excessively cautious, * but what the test suite checks for. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { /* * Technically, we could just pass a literal '::namespace inscope ' * term through, but that's something which really shouldn't be * occurring as something that the user writes so we'll just punt it. */ return TCL_ERROR; } /* * Now we can compile using the same strategy as [namespace code]'s normal * implementation does internally. Note that we can't bind the namespace * name directly here, because TclOO plays complex games with namespaces; * the value needs to be determined at runtime for safety. */ PushStringLiteral(envPtr, "::namespace"); PushStringLiteral(envPtr, "inscope"); TclEmitOpcode( INST_NS_CURRENT, envPtr); CompileWord(envPtr, tokenPtr, interp, 1); TclEmitInstInt4( INST_LIST, 4, envPtr); return TCL_OK; } int TclCompileNamespaceOriginCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr); return TCL_OK; } int TclCompileNamespaceQualifiersCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int off; if (parsePtr->numWords != 2) { return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); PushStringLiteral(envPtr, "0"); PushStringLiteral(envPtr, "::"); TclEmitInstInt4( INST_OVER, 2, envPtr); TclEmitOpcode( INST_STR_FIND_LAST, envPtr); off = CurrentOffset(envPtr); PushStringLiteral(envPtr, "1"); TclEmitOpcode( INST_SUB, envPtr); TclEmitInstInt4( INST_OVER, 2, envPtr); TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitOpcode( INST_STR_INDEX, envPtr); PushStringLiteral(envPtr, ":"); TclEmitOpcode( INST_STR_EQ, envPtr); off = off - CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); TclEmitOpcode( INST_STR_RANGE, envPtr); return TCL_OK; } int TclCompileNamespaceTailCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); JumpFixup jumpFixup; if (parsePtr->numWords != 2) { return TCL_ERROR; } /* * Take care; only add 2 to found index if the string was actually found. */ CompileWord(envPtr, tokenPtr, interp, 1); PushStringLiteral(envPtr, "::"); TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitOpcode( INST_STR_FIND_LAST, envPtr); TclEmitOpcode( INST_DUP, envPtr); PushStringLiteral(envPtr, "0"); TclEmitOpcode( INST_GE, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); PushStringLiteral(envPtr, "2"); TclEmitOpcode( INST_ADD, envPtr); TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); PushStringLiteral(envPtr, "end"); TclEmitOpcode( INST_STR_RANGE, envPtr); return TCL_OK; } int TclCompileNamespaceUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int localIndex, numWords, i; if (envPtr->procPtr == NULL) { return TCL_ERROR; } /* * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ numWords = (int)parsePtr->numWords; if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } /* * Push the namespace */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a * local variable, return an error so that the non-compiled command will * be called at runtime. */ localTokenPtr = tokenPtr; for (i=2; inumWords < 2 || (int)parsePtr->numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); idx = 1; /* * If there's an option, check that it's "-command". We don't handle * "-variable" (currently) and anything else is an error. */ if (parsePtr->numWords == 3) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } opt = tokenPtr + 1; if (opt->size < 2 || opt->size > 8 || strncmp(opt->start, "-command", opt->size) != 0) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); idx++; } /* * Issue the bytecode. */ CompileWord(envPtr, tokenPtr, interp, idx); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileRegexpCmd -- * * Procedure called to compile the "regexp" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "regexp" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileRegexpCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ size_t len; int i, nocase, exact, sawLast, simple; const char *str; /* * We are only interested in compiling simple regexp cases. Currently * supported compile cases are: * regexp ?-nocase? ?--? staticString $var * regexp ?-nocase? ?--? {^staticString$} $var */ if ((int)parsePtr->numWords < 3) { return TCL_ERROR; } simple = 0; nocase = 0; sawLast = 0; varTokenPtr = parsePtr->tokenPtr; /* * We only look for -nocase and -- as options. Everything else gets pushed * to runtime execution. This is different than regexp's runtime option * handling, but satisfies our stricter needs. */ for (i = 1; i < (int)parsePtr->numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * Not a simple string, so punt to runtime. */ return TCL_ERROR; } str = varTokenPtr[1].start; len = varTokenPtr[1].size; if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { sawLast++; i++; break; } else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) { nocase = 1; } else { /* * Not an option we recognize. */ return TCL_ERROR; } } if (((int)parsePtr->numWords - i) != 2) { /* * We don't support capturing to variables. */ return TCL_ERROR; } /* * Get the regexp string. If it is not a simple string or can't be * converted to a glob pattern, push the word for the INST_REGEXP. * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. */ varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { Tcl_DString ds; str = varTokenPtr[1].start; len = varTokenPtr[1].size; /* * If it has a '-', it could be an incorrectly formed regexp command. */ if ((*str == '-') && !sawLast) { return TCL_ERROR; } if (len == 0) { /* * The semantics of regexp are always match on re == "". */ PushStringLiteral(envPtr, "1"); return TCL_OK; } /* * Attempt to convert pattern to glob. If successful, push the * converted pattern as a literal. */ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } } if (!simple) { CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); } /* * Push the string arg. */ varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { TclEmitOpcode( INST_STR_EQ, envPtr); } else { TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); } } else { /* * Pass correct RE compile flags. We use only Int1 (8-bit), but * that handles all the flags we want to pass. * Don't use TCL_REG_NOSUB as we may have backrefs. */ int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); TclEmitInstInt1( INST_REGEXP, cflags, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileRegsubCmd -- * * Procedure called to compile the "regsub" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "regsub" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileRegsubCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds the resulting instructions. */ { /* * We only compile the case with [regsub -all] where the pattern is both * known at compile time and simple (i.e., no RE metacharacters). That is, * the pattern must be translatable into a glob like "*foo*" with no other * glob metacharacters inside it; there must be some "foo" in there too. * The substitution string must also be known at compile time and free of * metacharacters ("\digit" and "&"). Finally, there must not be a * variable mentioned in the [regsub] to write the result back to (because * we can't get the count of substitutions that would be the result in * that case). The key is that these are the conditions under which a * [string map] could be used instead, in particular a [string map] of the * form we can compile to bytecode. * * In short, we look for: * * regsub -all [--] simpleRE string simpleReplacement * * The only optional part is the "--", and no other options are handled. */ DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *stringTokenPtr; Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; int exact, quantified, result = TCL_ERROR; Tcl_Size len; if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) { return TCL_ERROR; } /* * Parse the "-all", which must be the first argument (other options not * supported, non-"-all" substitution we can't compile). */ tokenPtr = TokenAfter(parsePtr->tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 || strncmp(tokenPtr[1].start, "-all", 4)) { return TCL_ERROR; } /* * Get the pattern into patternObj, checking for "--" in the process. */ Tcl_DStringInit(&pattern); tokenPtr = TokenAfter(tokenPtr); TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } if (TclGetString(patternObj)[0] == '-') { if (strcmp(TclGetString(patternObj), "--") != 0 || parsePtr->numWords == 5) { goto done; } tokenPtr = TokenAfter(tokenPtr); Tcl_DecrRefCount(patternObj); TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } } else if (parsePtr->numWords == 6) { goto done; } /* * Identify the code which produces the string to apply the substitution * to (stringTokenPtr), and the replacement string (into replacementObj). */ stringTokenPtr = TokenAfter(tokenPtr); tokenPtr = TokenAfter(stringTokenPtr); TclNewObj(replacementObj); if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { goto done; } /* * Next, higher-level checks. Is the RE a very simple glob? Is the * replacement "simple"? */ bytes = TclGetStringFromObj(patternObj, &len); if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) != TCL_OK || exact || quantified) { goto done; } bytes = Tcl_DStringValue(&pattern); if (*bytes++ != '*') { goto done; } while (1) { switch (*bytes) { case '*': if (bytes[1] == '\0') { /* * OK, we've proved there are no metacharacters except for the * '*' at each end. */ len = Tcl_DStringLength(&pattern) - 2; if (len + 2 > 2) { goto isSimpleGlob; } /* * The pattern is "**"! I believe that should be impossible, * but we definitely can't handle that at all. */ } case '\0': case '?': case '[': case '\\': goto done; } bytes++; } isSimpleGlob: for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; } } /* * Proved the simplicity constraints! Time to issue the code. */ result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: Tcl_DStringFree(&pattern); if (patternObj) { Tcl_DecrRefCount(patternObj); } if (replacementObj) { Tcl_DecrRefCount(replacementObj); } return result; } /* *---------------------------------------------------------------------- * * TclCompileReturnCmd -- * * Procedure called to compile the "return" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "return" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileReturnCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ /* * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ int level, code, objc, status = TCL_OK; Tcl_Size size; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); /* * Check for special case which can always be compiled: * return -options * Unlike the normal [return] compilation, this version does everything at * runtime so it can handle arbitrary words and not just literals. Note * that if INST_RETURN_STK wasn't already needed for something else * ('finally' clause processing) this piece of code would not be present. */ if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && (wordTokenPtr[1].size == 8) && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } /* * Allocate some working space. */ objv = (Tcl_Obj **)TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); /* * Scan through the return options. If any are unknown at compile time, * there is no value in bytecompiling. Save the option values known in an * objv array for merging into a return options dictionary. * * TODO: There is potential for improvement if all option keys are known * at compile time and all option values relating to '-code' and '-level' * are known at compile time. */ for (objc = 0; objc < numOptionWords; objc++) { TclNewObj(objv[objc]); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { /* * Non-literal, so punt to run-time assembly of the dictionary. */ for (; objc>=0 ; objc--) { TclDecrRefCount(objv[objc]); } TclStackFree(interp, objv); goto issueRuntimeReturn; } wordTokenPtr = TokenAfter(wordTokenPtr); } status = TclMergeReturnOptions(interp, objc, objv, &returnOpts, &code, &level); while (--objc >= 0) { TclDecrRefCount(objv[objc]); } TclStackFree(interp, objv); if (TCL_ERROR == status) { /* * Something was bogus in the return options. Clear the error message, * and report back to the compiler that this must be interpreted at * runtime. */ Tcl_ResetResult(interp); return TCL_ERROR; } /* * All options are known at compile time, so we're going to bytecompile. * Emit instructions to push the result on the stack. */ if (explicitResult) { CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { /* * No explict result argument, so default result is empty string. */ PushStringLiteral(envPtr, ""); } /* * Check for optimization: When [return] is in a proc, and there's no * enclosing [catch], and there are no return options, then the INST_DONE * instruction is equivalent, and may be more efficient. */ if (numOptionWords == 0 && envPtr->procPtr != NULL) { /* * We have default return options and we're in a proc ... */ int index = envPtr->exceptArrayNext - 1; int enclosingCatch = 0; while (index >= 0) { ExceptionRange range = envPtr->exceptArrayPtr[index]; if ((range.type == CATCH_EXCEPTION_RANGE) && (range.catchOffset == TCL_INDEX_NONE)) { enclosingCatch = 1; break; } index--; } if (!enclosingCatch) { /* * ... and there is no enclosing catch. Issue the maximally * efficient exit instruction. */ Tcl_DecrRefCount(returnOpts); TclEmitOpcode(INST_DONE, envPtr); TclAdjustStackDepth(1, envPtr); return TCL_OK; } } /* Optimize [return -level 0 $x]. */ Tcl_DictObjSize(NULL, returnOpts, &size); if (size == 0 && level == 0 && code == TCL_OK) { Tcl_DecrRefCount(returnOpts); return TCL_OK; } /* * Could not use the optimization, so we push the return options dict, and * emit the INST_RETURN_IMM instruction with code and level as operands. */ CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; issueRuntimeReturn: /* * Assemble the option dictionary (as a list as that's good enough). */ wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (objc=1 ; objc<=numOptionWords ; objc++) { CompileWord(envPtr, wordTokenPtr, interp, objc); wordTokenPtr = TokenAfter(wordTokenPtr); } TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); /* * Push the result. */ if (explicitResult) { CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { PushStringLiteral(envPtr, ""); } /* * Issue the RETURN itself. */ TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } static void CompileReturnInternal( CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts) { if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) { ExceptionRange *rangePtr; ExceptionAux *exceptAux; rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { TclCleanupStackForBreakContinue(envPtr, exceptAux); if (code == TCL_BREAK) { TclAddLoopBreakFixup(envPtr, exceptAux); } else { TclAddLoopContinueFixup(envPtr, exceptAux); } Tcl_DecrRefCount(returnOpts); return; } } TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(op, code, envPtr); TclEmitInt4(level, envPtr); } void TclCompileSyntaxError( Tcl_Interp *interp, CompileEnv *envPtr) { Tcl_Obj *msg = Tcl_GetObjResult(interp); Tcl_Size numBytes; const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); } /* *---------------------------------------------------------------------- * * TclCompileUpvarCmd -- * * Procedure called to compile the "upvar" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "upvar" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int localIndex, numWords, i; Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } /* * Push the frame index if it is known at compile time */ TclNewObj(objPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; /* * Attempt to convert to a level reference. Note that TclObjGetFrame * only changes the obj type when a conversion was successful. */ TclObjGetFrame(interp, objPtr, &framePtr); newTypePtr = objPtr->typePtr; Tcl_DecrRefCount(objPtr); if (newTypePtr != typePtr) { if (numWords%2) { return TCL_ERROR; } /* TODO: Push the known value instead? */ CompileWord(envPtr, tokenPtr, interp, 1); otherTokenPtr = TokenAfter(tokenPtr); i = 2; } else { if (!(numWords%2)) { return TCL_ERROR; } PushStringLiteral(envPtr, "1"); otherTokenPtr = tokenPtr; i = 1; } } else { Tcl_DecrRefCount(objPtr); return TCL_ERROR; } /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a * local variable, return an error so that the non-compiled command will * be called at runtime. */ for (; inumWords; if (numWords < 2) { return TCL_ERROR; } /* * Bail out if not compiling a proc body */ if (envPtr->procPtr == NULL) { return TCL_ERROR; } /* * Loop over the (var, value) pairs. */ valueTokenPtr = parsePtr->tokenPtr; for (i=1; inumComponents; Tcl_Size len; Tcl_Token *lastTokenPtr; int full, localIndex; /* * Determine if the tail is (a) known at compile time, and (b) not an * array element. Should any of these fail, return an error so that the * non-compiled command will be called at runtime. * * In order for the tail to be known at compile time, the last token in * the word has to be constant and contain "::" if it is not the only one. */ if (!EnvHasLVT(envPtr)) { return -1; } TclNewObj(tailPtr); if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { full = 1; lastTokenPtr = varTokenPtr; } else { full = 0; lastTokenPtr = varTokenPtr + n; if (lastTokenPtr->type != TCL_TOKEN_TEXT) { Tcl_DecrRefCount(tailPtr); return -1; } Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size); } tailName = TclGetStringFromObj(tailPtr, &len); if (len) { if (*(tailName + len - 1) == ')') { /* * Possible array: bail out */ Tcl_DecrRefCount(tailPtr); return -1; } /* * Get the tail: immediately after the last '::' */ for (p = tailName + len -1; p > tailName; p--) { if ((p[0] == ':') && (p[- 1] == ':')) { p++; break; } } if (!full && (p == tailName)) { /* * No :: in the last component. */ Tcl_DecrRefCount(tailPtr); return -1; } len -= p - tailName; tailName = p; } localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); Tcl_DecrRefCount(tailPtr); return localIndex; } /* * ---------------------------------------------------------------------- * * TclCompileObjectNextCmd, TclCompileObjectSelfCmd -- * * Compilations of the TclOO utility commands [next] and [self]. * * ---------------------------------------------------------------------- */ int TclCompileObjectNextCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; if ((int)parsePtr->numWords > 255) { return TCL_ERROR; } for (i=0 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); return TCL_OK; } int TclCompileObjectNextToCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { return TCL_ERROR; } for (i=0 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr); return TCL_OK; } int TclCompileObjectSelfCmd( TCL_UNUSED(Tcl_Interp *), Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { /* * We only handle [self] and [self object] (which is the same operation). * These are the only very common operations on [self] for which * bytecoding is at all reasonable. */ if (parsePtr->numWords == 1) { goto compileSelfObject; } else if (parsePtr->numWords == 2) { Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { return TCL_ERROR; } subcmd = tokenPtr + 1; if (strncmp(subcmd->start, "object", subcmd->size) == 0) { goto compileSelfObject; } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { goto compileSelfNamespace; } } /* * Can't compile; handle with runtime call. */ return TCL_ERROR; compileSelfObject: /* * This delegates the entire problem to a single opcode. */ TclEmitOpcode( INST_TCLOO_SELF, envPtr); return TCL_OK; compileSelfNamespace: /* * This is formally only correct with TclOO methods as they are currently * implemented; it assumes that the current namespace is invariably when a * TclOO context is present is the object's namespace, and that's * technically only something that's a matter of current policy. But it * avoids creating another opcode, so that's all good! */ TclEmitOpcode( INST_TCLOO_SELF, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_NS_CURRENT, envPtr); return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */