diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2010-02-26 14:38:35 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2010-02-26 14:38:35 (GMT) |
commit | 42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7 (patch) | |
tree | a8d7630b12ddf60ab8264a7f04d71dd92b8b7874 /generic/tclCompCmds.c | |
parent | 43489532dea0636fb88a85b2b5fa8097b27166da (diff) | |
download | tcl-42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7.zip tcl-42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7.tar.gz tcl-42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7.tar.bz2 |
Split tclCompCmds.c into two pieces to improve developer sanity.
Diffstat (limited to 'generic/tclCompCmds.c')
-rw-r--r-- | generic/tclCompCmds.c | 3916 |
1 files changed, 375 insertions, 3541 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 280ab5e..3a564ff 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.166 2010/02/25 10:56:16 dkf Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.167 2010/02/26 14:38:36 dkf Exp $ */ #include "tclInt.h" @@ -32,54 +32,16 @@ static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static ClientData DupJumptableInfo(ClientData clientData); -static void FreeJumptableInfo(ClientData clientData); -static void PrintJumptableInfo(ClientData clientData, - Tcl_Obj *appendObj, ByteCode *codePtr, - unsigned int pcOffset); +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); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); -static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, const char *identity, - int instruction, CompileEnv *envPtr); -static int CompileComparisonOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int instruction, - CompileEnv *envPtr); -static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int instruction, - CompileEnv *envPtr); -static int CompileUnaryOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int instruction, - CompileEnv *envPtr); -static void CompileReturnInternal(CompileEnv *envPtr, - unsigned char op, int code, int level, - Tcl_Obj *returnOpts); -static void IssueSwitchChainedTests(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int mode, int noCase, - int valueIndex, Tcl_Token *valueTokenPtr, - int numWords, Tcl_Token **bodyToken, - int *bodyLines, int **bodyNext); -static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int valueIndex, - Tcl_Token *valueTokenPtr, int numWords, - Tcl_Token **bodyToken, int *bodyLines, - int **bodyContLines); -static int IssueTryFinallyInstructions(Tcl_Interp *interp, - CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, int *matchCodes, - Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens, - Tcl_Token *finallyToken); -static int IssueTryInstructions(Tcl_Interp *interp, - CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, int *matchCodes, - Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens); /* * Macro that encapsulates an efficiency trick that avoids a function call for @@ -139,13 +101,6 @@ const AuxDataType tclForeachInfoType = { PrintForeachInfo /* printProc */ }; -const AuxDataType tclJumptableInfoType = { - "JumptableInfo", /* name */ - DupJumptableInfo, /* dupProc */ - FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo /* printProc */ -}; - const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ @@ -2026,6 +1981,81 @@ PrintForeachInfo( /* *---------------------------------------------------------------------- * + * 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. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + 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 + */ + + PushLiteral(envPtr, "::", 2); + + /* + * Loop over the variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if (localIndex < 0) { + return TCL_ERROR; + } + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileIfCmd -- * * Procedure called to compile the "if" command. @@ -2462,6 +2492,78 @@ TclCompileIncrCmd( /* *---------------------------------------------------------------------- * + * TclCompileInfoExistsCmd -- + * + * Procedure called to compile the "info exists" subcommand. + * + * 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 exists" + * subcommand at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInfoExistsCmd( + 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 defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int isScalar, simpleVarName, localIndex; + DefineLineInformation; /* TIP #280 */ + + 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, + &simpleVarName, &isScalar, 1); + + /* + * Emit instruction to check the variable for existence. + */ + + if (simpleVarName) { + 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); + } + } + } else { + TclEmitOpcode(INST_EXIST_STK, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. @@ -3066,6 +3168,98 @@ TclCompileLsetCmd( /* *---------------------------------------------------------------------- * + * TclCompileNamespaceCmd -- + * + * Procedure called to compile the "namespace" command; currently, only + * the subcommand "namespace upvar" is compiled to bytecodes. + * + * 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 +TclCompileNamespaceCmd( + 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 defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Only compile [namespace upvar ...]: needs an odd number of args, >=5 + */ + + numWords = parsePtr->numWords; + if (!(numWords%2) || (numWords < 5)) { + return TCL_ERROR; + } + + /* + * Check if the second argument is "upvar" + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */ + || strncmp(tokenPtr->start, "upvar", 5)) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + tokenPtr = TokenAfter(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=4; i<=numWords; i+=2) { + otherTokenPtr = TokenAfter(localTokenPtr); + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, 1); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + + if ((localIndex < 0) || !isScalar) { + return TCL_ERROR; + } + TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileRegexpCmd -- * * Procedure called to compile the "regexp" command. @@ -3425,224 +3619,23 @@ TclCompileSyntaxError( /* *---------------------------------------------------------------------- * - * TclCompileSetCmd -- + * TclCompileUpvarCmd -- * - * Procedure called to compile the "set" command. + * 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 "set" command at + * Instructions are added to envPtr to execute the "upvar" command at * runtime. * *---------------------------------------------------------------------- */ int -TclCompileSetCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int isAssignment, isScalar, simpleVarName, localIndex, numWords; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - if ((numWords != 2) && (numWords != 3)) { - return TCL_ERROR; - } - isAssignment = (numWords == 3); - - /* - * 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, &simpleVarName, &isScalar, 1); - - /* - * If we are doing an assignment, push the new value. - */ - - if (isAssignment) { - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); - } - - /* - * Emit instructions to set/get the variable. - */ - - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); - } - } - } else { - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringCmpCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string compare" 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 "string compare" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringCmpCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_CMP, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringEqualCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string equal" 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 "string equal" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringEqualCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_EQ, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringIndexCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string index" 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 "string index" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringIndexCmd( +TclCompileUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ @@ -3650,1434 +3643,108 @@ TclCompileStringIndexCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Obj *objPtr = Tcl_NewObj(); - if (parsePtr->numWords != 3) { + if (envPtr->procPtr == NULL) { + Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - /* - * Push the two operands onto the stack and then the index operation. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_INDEX, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringMatchCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string match" 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 "string match" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringMatchCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int i, length, exactMatch = 0, nocase = 0; - const char *str; - - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { + numWords = parsePtr->numWords; + if (numWords < 3) { + Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Check if we have a -nocase flag. - */ - - if (parsePtr->numWords == 4) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { - /* - * Fail at run time, not in compilation. - */ - - return TCL_ERROR; - } - nocase = 1; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Push the strings to match against each other. - */ - - for (i = 0; i < 2; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if (!nocase && (i == 0)) { - /* - * Trivial matches can be done by 'string equal'. If -nocase - * was specified, we can't do this because INST_STR_EQ has no - * support for nocase. - */ - - Tcl_Obj *copy = Tcl_NewStringObj(str, length); - - Tcl_IncrRefCount(copy); - exactMatch = TclMatchIsTrivial(TclGetString(copy)); - TclDecrRefCount(copy); - } - PushLiteral(envPtr, str, length); - } else { - SetLineInformation(i+1+nocase); - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } /* - * Push the matcher. + * Push the frame index if it is known at compile time */ - if (exactMatch) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringLenCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string length" 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 "string length" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringLenCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - TclNewObj(objPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - /* - * Here someone is asking for the length of a static string (or - * something with backslashes). Just push the actual character (not - * byte) length. - */ - - char buf[TCL_INTEGER_SPACE]; - int len = Tcl_GetCharLength(objPtr); - - len = sprintf(buf, "%d", len); - PushLiteral(envPtr, buf, len); - } else { - SetLineInformation(1); - CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_STR_LEN, envPtr); - } - TclDecrRefCount(objPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSubstCmd -- - * - * Procedure called to compile the "subst" command. - * - * Results: - * Returns TCL_OK for successful compile, or TCL_ERROR to defer - * evaluation to runtime (either when it is too complex to get the - * semantics right, or when we know for sure that it is an error but need - * the error to happen at the right time). - * - * Side effects: - * Instructions are added to envPtr to execute the "subst" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSubstCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - int numArgs = parsePtr->numWords - 1; - int numOpts = numArgs - 1; - int objc, flags = TCL_SUBST_ALL; - Tcl_Obj **objv/*, *toSubst = NULL*/; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - int code = TCL_ERROR; - DefineLineInformation; /* TIP #280 */ - - if (numArgs == 0) { - return TCL_ERROR; - } - - objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); - - for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { - objv[objc] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - goto cleanup; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - -/* - if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) { - toSubst = objv[numOpts]; - Tcl_IncrRefCount(toSubst); - } -*/ - - /* TODO: Figure out expansion to cover WordKnownAtCompileTime - * The difficulty is that WKACT makes a copy, and if TclSubstParse - * below parses the copy of the original source string, some deep - * parts of the compile machinery get upset. They want all pointers - * stored in Tcl_Tokens to point back to the same original string. - */ - if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - code = TclSubstOptions(NULL, numOpts, objv, &flags); - } - - cleanup: - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (/*toSubst == NULL*/ code != TCL_OK) { - return TCL_ERROR; - } - - SetLineInformation(numArgs); - TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, - flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); - -/* TclDecrRefCount(toSubst);*/ - return TCL_OK; -} - -void -TclSubstCompile( - Tcl_Interp *interp, - const char *bytes, - int numBytes, - int flags, - int line, - CompileEnv *envPtr) -{ - Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0, bline = line; - Tcl_Parse parse; - Tcl_InterpState state = NULL; - - TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); - - for (tokenPtr = parse.tokenPtr, endTokenPtr = tokenPtr + parse.numTokens; - tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - int length, literal, catchRange, breakJump; - char buf[TCL_UTF_MAX]; - JumpFixup startFixup, okFixup, returnFixup, breakFixup; - JumpFixup continueFixup, otherFixup, endFixup; - - switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - literal = TclRegisterNewLiteral(envPtr, - tokenPtr->start, tokenPtr->size); - TclEmitPush(literal, envPtr); - TclAdvanceLines(&bline, tokenPtr->start, - tokenPtr->start + tokenPtr->size); - count++; - continue; - case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, NULL, buf); - literal = TclRegisterNewLiteral(envPtr, buf, length); - TclEmitPush(literal, envPtr); - count++; - continue; - } - - while (count > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); - count -= 254; - } - if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); - count = 1; - } - - if (breakOffset == 0) { - /* Jump to the start (jump over the jump to end) */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); - - /* Jump to the end (all BREAKs land here) */ - breakOffset = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); - - /* Start */ - if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", - CurrentOffset(envPtr) - startFixup.codeOffset); - } - } - - envPtr->line = bline; - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr); - ExceptionRangeStarts(envPtr, catchRange); - - switch (tokenPtr->type) { - case TCL_TOKEN_COMMAND: - TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, - envPtr); - count++; - break; - case TCL_TOKEN_VARIABLE: - TclCompileVarSubst(interp, tokenPtr, envPtr); - count++; - break; - default: - Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", - tokenPtr->type); - } - - ExceptionRangeEnds(envPtr, catchRange); - - /* Substitution produced TCL_OK */ - TclEmitOpcode(INST_END_CATCH, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); - - /* Exceptional return codes processed here */ - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - TclEmitOpcode(INST_END_CATCH, envPtr); - TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr); - - /* ERROR -> reraise it */ - TclEmitOpcode(INST_RETURN_STK, envPtr); - TclEmitOpcode(INST_NOP, envPtr); - - /* RETURN */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); - - /* BREAK */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); - - /* CONTINUE */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); - - /* OTHER */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); - - /* BREAK destination */ - if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", - CurrentOffset(envPtr) - breakFixup.codeOffset); - } - TclEmitOpcode(INST_POP, envPtr); - TclEmitOpcode(INST_POP, envPtr); - - breakJump = CurrentOffset(envPtr) - breakOffset; - if (breakJump > 127) { - TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr); - } - - /* CONTINUE destination */ - if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", - CurrentOffset(envPtr) - continueFixup.codeOffset); - } - TclEmitOpcode(INST_POP, envPtr); - TclEmitOpcode(INST_POP, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); - - /* RETURN + other destination */ - if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", - CurrentOffset(envPtr) - returnFixup.codeOffset); - } - if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", - CurrentOffset(envPtr) - otherFixup.codeOffset); - } - /* Pull the result to top of stack, discard options dict */ - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_POP, envPtr); - - /* - * We've emitted several POP instructions, and the automatic - * computations for stack depth requirements have been decrementing - * for every one. However, we know that every branch actually taken - * only encounters some of those instructions. No branch passes - * through them all. So, we now have a stack requirements estimate - * that is too low. Here we manually fix that up. - */ - TclAdjustStackDepth(5, envPtr); - - /* OK destination */ - if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", - CurrentOffset(envPtr) - okFixup.codeOffset); - } - if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); - count = 1; - } - - /* CONTINUE jump to here */ - if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", - CurrentOffset(envPtr) - endFixup.codeOffset); - } - bline = envPtr->line; - } - - - while (count > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); - count -= 254; - } - if (count > 1) { - TclEmitInstInt1(INST_CONCAT1, count, envPtr); - } - - Tcl_FreeParse(&parse); - - if (state != NULL) { - Tcl_RestoreInterpState(interp, state); - TclCompileSyntaxError(interp, envPtr); - } - - /* Final target of the multi-jump from all BREAKs */ - if (breakOffset > 0) { - TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, - envPtr->codeStart + breakOffset); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSwitchCmd -- - * - * Procedure called to compile the "switch" command. - * - * Results: - * Returns TCL_OK for successful compile, or TCL_ERROR to defer - * evaluation to runtime (either when it is too complex to get the - * semantics right, or when we know for sure that it is an error but need - * the error to happen at the right time). - * - * Side effects: - * Instructions are added to envPtr to execute the "switch" command at - * runtime. - * - * FIXME: - * Stack depths are probably not calculated correctly. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSwitchCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; /* Pointer to tokens in command. */ - int numWords; /* Number of words in command. */ - Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ - enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; - /* What kind of switch are we doing? */ - Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ - Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ - int *bodyLines; /* Array of line numbers for body list - * items. */ - int **bodyContLines; /* Array of continuation line info. */ - int noCase; /* Has the -nocase flag been given? */ - int foundMode = 0; /* Have we seen a mode flag yet? */ - int isListedArms = 0; - int i, valueIndex; - int result = TCL_ERROR; - DefineLineInformation; /* TIP #280 */ - int *clNext = envPtr->clNext; - - /* - * Only handle the following versions: - * switch ?--? word {pattern body ...} - * switch -exact ?--? word {pattern body ...} - * switch -glob ?--? word {pattern body ...} - * switch -regexp ?--? word {pattern body ...} - * switch -- word simpleWordPattern simpleWordBody ... - * switch -exact -- word simpleWordPattern simpleWordBody ... - * switch -glob -- word simpleWordPattern simpleWordBody ... - * switch -regexp -- word simpleWordPattern simpleWordBody ... - * When the mode is -glob, can also handle a -nocase flag. - * - * First off, we don't care how the command's word was generated; we're - * compiling it anyway! So skip it... - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - valueIndex = 1; - numWords = parsePtr->numWords-1; - - /* - * Check for options. - */ - - noCase = 0; - mode = Switch_Exact; - if (numWords == 2) { - /* - * There's just the switch value and the bodies list. In that case, we - * can skip all option parsing and move on to consider switch values - * and the body list. - */ - - goto finishedOptionParse; - } - - /* - * There must be at least one option, --, because without that there is no - * way to statically avoid the problems you get from strings-to-be-matched - * that start with a - (the interpreted code falls apart if it encounters - * them, so we punt if we *might* encounter them as that is the easiest - * way of emulating the behaviour). - */ - - for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { - register unsigned size = tokenPtr[1].size; - register const char *chrs = tokenPtr[1].start; + CallFrame *framePtr; + const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; /* - * We only process literal options, and we assume that -e, -g and -n - * are unique prefixes of -exact, -glob and -nocase respectively (true - * at time of writing). Note that -exact and -glob may only be given - * at most once or we bail out (error case). + * Attempt to convert to a level reference. Note that TclObjGetFrame + * only changes the obj type when a conversion was successful. */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { - return TCL_ERROR; - } + TclObjGetFrame(interp, objPtr, &framePtr); + newTypePtr = objPtr->typePtr; + Tcl_DecrRefCount(objPtr); - if ((size <= 6) && !memcmp(chrs, "-exact", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Exact; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { - if (foundMode) { + if (newTypePtr != typePtr) { + if (numWords%2) { return TCL_ERROR; } - mode = Switch_Glob; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { - if (foundMode) { + CompileWord(envPtr, tokenPtr, interp, 1); + otherTokenPtr = TokenAfter(tokenPtr); + i = 4; + } else { + if (!(numWords%2)) { return TCL_ERROR; } - mode = Switch_Regexp; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { - noCase = 1; - valueIndex++; - continue; - } else if ((size == 2) && !memcmp(chrs, "--", 2)) { - valueIndex++; - break; + PushLiteral(envPtr, "1", 1); + otherTokenPtr = tokenPtr; + i = 3; } - - /* - * The switch command has many flags we cannot compile at all (e.g. - * all the RE-related ones) which we must have encountered. Either - * that or we have run off the end. The action here is the same: punt - * to interpreted version. - */ - - return TCL_ERROR; - } - if (numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - numWords--; - if (noCase && (mode == Switch_Exact)) { - /* - * Can't compile this case; no opcode for case-insensitive equality! - */ - + } else { + Tcl_DecrRefCount(objPtr); return TCL_ERROR; } /* - * The value to test against is going to always get pushed on the stack. - * But not yet; we need to verify that the rest of the command is - * compilable too. - */ - - finishedOptionParse: - valueTokenPtr = tokenPtr; - /* For valueIndex, see previous loop. */ - tokenPtr = TokenAfter(tokenPtr); - numWords--; - - /* - * Build an array of tokens for the matcher terms and script bodies. Note - * that in the case of the quoted bodies, this is tricky as we cannot use - * copies of the string from the input token for the generated tokens (it - * causes a crash during exception handling). When multiple tokens are - * available at this point, this is pretty easy. + * 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. */ - if (numWords == 1) { - Tcl_DString bodyList; - const char **argv = NULL, *tokenStartPtr, *p; - int bline; /* TIP #280: line of the pattern/action list, - * and start of list for when tracking the - * location. This list comes immediately after - * the value we switch on. */ - int isTokenBraced; - - /* - * Test that we've got a suitable body list as a simple (i.e. braced) - * word, and that the elements of the body are simple words too. This - * is really rather nasty indeed. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - Tcl_DStringInit(&bodyList); - Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); - if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords, - &argv) != TCL_OK) { - Tcl_DStringFree(&bodyList); - return TCL_ERROR; - } - Tcl_DStringFree(&bodyList); + for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + localTokenPtr = TokenAfter(otherTokenPtr); - /* - * Now we know what the switch arms are, we've got to see whether we - * can synthesize tokens for the arms. First check whether we've got a - * valid number of arms since we can do that now. - */ + CompileWord(envPtr, otherTokenPtr, interp, 1); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); - if (numWords == 0 || numWords % 2) { - ckfree((char *) argv); + if ((localIndex < 0) || !isScalar) { return TCL_ERROR; } - - isListedArms = 1; - bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *) ckalloc(sizeof(int) * numWords); - bodyContLines = (int **) ckalloc(sizeof(int*) * numWords); - - /* - * Locate the start of the arms within the overall word. - */ - - bline = mapPtr->loc[eclIndex].line[valueIndex+1]; - p = tokenStartPtr = tokenPtr[1].start; - while (isspace(UCHAR(*tokenStartPtr))) { - tokenStartPtr++; - } - if (*tokenStartPtr == '{') { - tokenStartPtr++; - isTokenBraced = 1; - } else { - isTokenBraced = 0; - } - - /* - * TIP #280: Count lines within the literal list. - */ - - for (i=0 ; i<numWords ; i++) { - bodyTokenArray[i].type = TCL_TOKEN_TEXT; - bodyTokenArray[i].start = tokenStartPtr; - bodyTokenArray[i].size = strlen(argv[i]); - bodyTokenArray[i].numComponents = 0; - bodyToken[i] = bodyTokenArray+i; - tokenStartPtr += bodyTokenArray[i].size; - - /* - * Test to see if we have guessed the end of the word correctly; - * if not, we can't feed the real string to the sub-compilation - * engine, and we're then stuck and so have to punt out to doing - * everything at runtime. - */ - - if ((isTokenBraced && *(tokenStartPtr++) != '}') || - (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size - && !isspace(UCHAR(*tokenStartPtr)))) { - ckfree((char *) argv); - goto freeTemporaries; - } - - /* - * TIP #280: Now determine the line the list element starts on - * (there is no need to do it earlier, due to the possibility of - * aborting, see above). - */ - - TclAdvanceLines(&bline, p, bodyTokenArray[i].start); - TclAdvanceContinuations(&bline, &clNext, - bodyTokenArray[i].start - envPtr->source); - bodyLines[i] = bline; - bodyContLines[i] = clNext; - p = bodyTokenArray[i].start; - - while (isspace(UCHAR(*tokenStartPtr))) { - tokenStartPtr++; - if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) { - break; - } - } - if (*tokenStartPtr == '{') { - tokenStartPtr++; - isTokenBraced = 1; - } else { - isTokenBraced = 0; - } - } - ckfree((char *) argv); - - /* - * Check that we've parsed everything we thought we were going to - * parse. If not, something odd is going on (I believe it is possible - * to defeat the code above) and we should bail out. - */ - - if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { - goto freeTemporaries; - } - - } else if (numWords % 2 || numWords == 0) { - /* - * Odd number of words (>1) available, or no words at all available. - * Both are error cases, so punt and let the interpreted-version - * generate the error message. Note that the second case probably - * should get caught earlier, but it's easy to check here again anyway - * because it'd cause a nasty crash otherwise. - */ - - return TCL_ERROR; - } else { - /* - * Multi-word definition of patterns & actions. - */ - - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *) ckalloc(sizeof(int) * numWords); - bodyContLines = (int **) ckalloc(sizeof(int*) * numWords); - bodyTokenArray = NULL; - for (i=0 ; i<numWords ; i++) { - /* - * We only handle the very simplest case. Anything more complex is - * a good reason to go to the interpreted case anyway due to - * traces, etc. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || - tokenPtr->numComponents != 1) { - goto freeTemporaries; - } - bodyToken[i] = tokenPtr+1; - - /* - * TIP #280: Copy line information from regular cmd info. - */ - - bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; - bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; - tokenPtr = TokenAfter(tokenPtr); - } - } - - /* - * Fall back to interpreted if the last body is a continuation (it's - * illegal, but this makes the error happen at the right time). - */ - - if (bodyToken[numWords-1]->size == 1 && - bodyToken[numWords-1]->start[0] == '-') { - goto freeTemporaries; - } - - /* - * Now we commit to generating code; the parsing stage per se is done. - * Check if we can generate a jump table, since if so that's faster than - * doing an explicit compare with each body. Note that we're definitely - * over-conservative with determining whether we can do the jump table, - * but it handles the most common case well enough. - */ - - if ((isListedArms) && (mode == Switch_Exact) && (!noCase)) { - IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex, - valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines); - } else { - IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase, - valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines, - bodyContLines); - } - result = TCL_OK; - - /* - * Clean up all our temporary space and return. - */ - - freeTemporaries: - ckfree((char *) bodyToken); - ckfree((char *) bodyLines); - ckfree((char *) bodyContLines); - if (bodyTokenArray != NULL) { - ckfree((char *) bodyTokenArray); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * IssueSwitchChainedTests -- - * - * Generate instructions for a [switch] command that is to be compiled - * into a sequence of tests. This is the generic handle-everything mode - * that inherently has performance that is (on average) linear in the - * number of tests. It is the only mode that can handle -glob and -regexp - * matches, or anything that is case-insensitive. It does not handle the - * wild-and-wooly end of regexp matching (i.e., capture of match results) - * so that's when we spill to the interpreted version. - * - *---------------------------------------------------------------------- - */ - -static void -IssueSwitchChainedTests( - Tcl_Interp *interp, /* Context for compiling script bodies. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, - int mode, /* Exact, Glob or Regexp */ - int noCase, /* Case-insensitivity flag. */ - int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, - int numBodyTokens, /* Number of tokens describing things the - * switch can match against and bodies to - * execute when the match succeeds. */ - Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - int *bodyLines, /* Array of line numbers for body list - * items. */ - int **bodyContLines) /* Array of continuation line info. */ -{ - enum {Switch_Exact, Switch_Glob, Switch_Regexp}; - int savedStackDepth = envPtr->currStackDepth; - int foundDefault; /* Flag to indicate whether a "default" clause - * is present. */ - JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ - int *fixupTargetArray; /* Array of places for fixups to point at. */ - int fixupCount; /* Number of places to fix up. */ - int contFixIndex; /* Where the first of the jumps due to a group - * of continuation bodies starts, or -1 if - * there aren't any. */ - int contFixCount; /* Number of continuation bodies pointing to - * the current (or next) real body. */ - int nextArmFixupIndex; - int simple, exact; /* For extracting the type of regexp. */ - int i; - - /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* - * Generate a test for each arm. - */ - - contFixIndex = -1; - contFixCount = 0; - fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens); - fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens); - memset(fixupTargetArray, 0, numBodyTokens * sizeof(int)); - fixupCount = 0; - foundDefault = 0; - for (i=0 ; i<numBodyTokens ; i+=2) { - nextArmFixupIndex = -1; - envPtr->currStackDepth = savedStackDepth + 1; - if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { - /* - * Generate the test for the arm. - */ - - switch (mode) { - case Switch_Exact: - TclEmitOpcode(INST_DUP, envPtr); - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitOpcode(INST_STR_EQ, envPtr); - break; - case Switch_Glob: - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); - break; - case Switch_Regexp: - simple = exact = 0; - - /* - * Keep in sync with TclCompileRegexpCmd. - */ - - if (bodyToken[i]->type == TCL_TOKEN_TEXT) { - Tcl_DString ds; - - if (bodyToken[i]->size == 0) { - /* - * The semantics of regexps are that they always match - * when the RE == "". - */ - - PushLiteral(envPtr, "1", 1); - break; - } - - /* - * Attempt to convert pattern to glob. If successful, push - * the converted pattern. - */ - - if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact) == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - if (!simple) { - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - } - - TclEmitInstInt4(INST_OVER, 1, envPtr); - if (!simple) { - /* - * 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 - * or capture vars. - */ - - int cflags = TCL_REG_ADVANCED - | (noCase ? TCL_REG_NOCASE : 0); - - TclEmitInstInt1(INST_REGEXP, cflags, envPtr); - } else if (exact && !noCase) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); - } - break; - default: - Tcl_Panic("unknown switch mode: %d", mode); - } - - /* - * In a fall-through case, we will jump on _true_ to the place - * where the body starts (generated later, with guarantee of this - * ensured earlier; the final body is never a fall-through). - */ - - if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { - if (contFixIndex == -1) { - contFixIndex = fixupCount; - contFixCount = 0; - } - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &fixupArray[contFixIndex+contFixCount]); - fixupCount++; - contFixCount++; - continue; - } - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &fixupArray[fixupCount]); - nextArmFixupIndex = fixupCount; - fixupCount++; - } else { - /* - * Got a default clause; set a flag to inhibit the generation of - * the jump after the body and the cleanup of the intermediate - * value that we are switching against. - * - * Note that default clauses (which are always terminal clauses) - * cannot be fall-through clauses as well, since the last clause - * is never a fall-through clause (which we have already - * verified). - */ - - foundDefault = 1; - } - - /* - * Generate the body for the arm. This is guaranteed not to be a - * fall-through case, but it might have preceding fall-through cases, - * so we must process those first. - */ - - if (contFixIndex != -1) { - int j; - - for (j=0 ; j<contFixCount ; j++) { - fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr); - } - contFixIndex = -1; - } - - /* - * Now do the actual compilation. Note that we do not use CompileBody - * because we may have synthesized the tokens in a non-standard - * pattern. - */ - - TclEmitOpcode(INST_POP, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - envPtr->line = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - if (!foundDefault) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &fixupArray[fixupCount]); - fixupCount++; - fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); - } - } - - /* - * Discard the value we are matching against unless we've had a default - * clause (in which case it will already be gone due to the code at the - * start of processing an arm, guaranteed) and make the result of the - * command an empty string. - */ - - if (!foundDefault) { - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - } - - /* - * Do jump fixups for arms that were executed. First, fill in the jumps of - * all jumps that don't point elsewhere to point to here. - */ - - for (i=0 ; i<fixupCount ; i++) { - if (fixupTargetArray[i] == 0) { - fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart; - } - } - - /* - * Now scan backwards over all the jumps (all of which are forward jumps) - * doing each one. When we do one and there is a size changes, we must - * scan back over all the previous ones and see if they need adjusting - * before proceeding with further jump fixups (the interleaved nature of - * all the jumps makes this impossible to do without nested loops). - */ - - for (i=fixupCount-1 ; i>=0 ; i--) { - if (TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { - int j; - - for (j=i-1 ; j>=0 ; j--) { - if (fixupTargetArray[j] > fixupArray[i].codeOffset) { - fixupTargetArray[j] += 3; - } - } - } - } - TclStackFree(interp, fixupTargetArray); - TclStackFree(interp, fixupArray); - - envPtr->currStackDepth = savedStackDepth + 1; -} - -/* - *---------------------------------------------------------------------- - * - * IssueSwitchJumpTable -- - * - * Generate instructions for a [switch] command that is to be compiled - * into a jump table. This only handles the case where case-sensitive, - * exact matching is used, but this is actually the most common case in - * real code. - * - *---------------------------------------------------------------------- - */ - -static void -IssueSwitchJumpTable( - Tcl_Interp *interp, /* Context for compiling script bodies. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, - int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, - int numBodyTokens, /* Number of tokens describing things the - * switch can match against and bodies to - * execute when the match succeeds. */ - Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - int *bodyLines, /* Array of line numbers for body list - * items. */ - int **bodyContLines) /* Array of continuation line info. */ -{ - JumptableInfo *jtPtr; - int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; - int mustGenerate, foundDefault, jumpToDefault, i; - Tcl_DString buffer; - Tcl_HashEntry *hPtr; - - /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* - * Compile the switch by using a jump table, which is basically a - * hashtable that maps from literal values to match against to the offset - * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump - * table itself is independent of any invokation of the bytecode, and as - * such is stored in an auxData block. - * - * Start by allocating the jump table itself, plus some workspace. - */ - - jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo)); - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); - foundDefault = 0; - mustGenerate = 1; - - /* - * Next, issue the instruction to do the jump, together with what we want - * to do if things do not work out (jump to either the default clause or - * the "default" default, which just sets the result to empty). Note that - * we will come back and rewrite the jump's offset parameter when we know - * what it should be, and that all jumps we issue are of the wide kind - * because that makes the code much easier to debug! - */ - - jumpLocation = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr); - jumpToDefault = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); - - for (i=0 ; i<numBodyTokens ; i+=2) { - /* - * For each arm, we must first work out what to do with the match - * term. - */ - - if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { - /* - * This is not a default clause, so insert the current location as - * a target in the jump table (assuming it isn't already there, - * which would indicate that this clause is probably masked by an - * earlier one). Note that we use a Tcl_DString here simply - * because the hash API does not let us specify the string length. - */ - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, bodyToken[i]->start, - bodyToken[i]->size); - hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, - Tcl_DStringValue(&buffer), &isNew); - if (isNew) { - /* - * First time we've encountered this match clause, so it must - * point to here. - */ - - Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation); - } - Tcl_DStringFree(&buffer); - } else { - /* - * This is a default clause, so patch up the fallthrough from the - * INST_JUMP_TABLE instruction to here. - */ - - foundDefault = 1; - isNew = 1; - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - } - - /* - * Now, for each arm we must deal with the body of the clause. - * - * If this is a continuation body (never true of a final clause, - * whether default or not) we're done because the next jump target - * will also point here, so we advance to the next clause. - */ - - if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { - mustGenerate = 1; - continue; - } - - /* - * Also skip this arm if its only match clause is masked. (We could - * probably be more aggressive about this, but that would be much more - * difficult to get right.) - */ - - if (!isNew && !mustGenerate) { - continue; - } - mustGenerate = 0; - - /* - * Compile the body of the arm. - */ - - envPtr->line = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - /* - * Compile a jump in to the end of the command if this body is - * anything other than a user-supplied default arm (to either skip - * over the remaining bodies or the code that generates an empty - * result). - */ - - if (i+2 < numBodyTokens || !foundDefault) { - finalFixups[numRealBodies++] = CurrentOffset(envPtr); - - /* - * Easier by far to issue this jump as a fixed-width jump, since - * otherwise we'd need to do a lot more (and more awkward) - * rewriting when we fixed this all up. - */ - - TclEmitInstInt4(INST_JUMP4, 0, envPtr); - } - } - - /* - * We're at the end. If we've not already done so through the processing - * of a user-supplied default clause, add in a "default" default clause - * now. - */ - - if (!foundDefault) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - PushLiteral(envPtr, "", 0); - } - - /* - * No more instructions to be issued; everything that needs to jump to the - * end of the command is fixed up at this point. - */ - - for (i=0 ; i<numRealBodies ; i++) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i], - envPtr->codeStart+finalFixups[i]+1); + TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); } /* - * Clean up all our temporary space and return. + * Pop the frame index, and set the result to empty */ - TclStackFree(interp, finalFixups); -} - -/* - *---------------------------------------------------------------------- - * - * DupJumptableInfo, FreeJumptableInfo -- - * - * Functions to duplicate, release and print a jump-table created for use - * with the INST_JUMP_TABLE instruction. - * - * Results: - * DupJumptableInfo: a copy of the jump-table - * FreeJumptableInfo: none - * PrintJumptableInfo: none - * - * Side effects: - * DupJumptableInfo: allocates memory - * FreeJumptableInfo: releases memory - * PrintJumptableInfo: none - * - *---------------------------------------------------------------------- - */ - -static ClientData -DupJumptableInfo( - ClientData clientData) -{ - JumptableInfo *jtPtr = clientData; - JumptableInfo *newJtPtr = (JumptableInfo *) - ckalloc(sizeof(JumptableInfo)); - Tcl_HashEntry *hPtr, *newHPtr; - Tcl_HashSearch search; - int isNew; - - Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - while (hPtr != NULL) { - newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable, - Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew); - Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); - } - return newJtPtr; -} - -static void -FreeJumptableInfo( - ClientData clientData) -{ - JumptableInfo *jtPtr = clientData; - - Tcl_DeleteHashTable(&jtPtr->hashTable); - ckfree((char *) jtPtr); -} - -static void -PrintJumptableInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - register JumptableInfo *jtPtr = clientData; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - const char *keyPtr; - int offset, i = 0; - - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { - keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); - offset = PTR2INT(Tcl_GetHashValue(hPtr)); - - if (i++) { - Tcl_AppendToObj(appendObj, ", ", -1); - if (i%4==0) { - Tcl_AppendToObj(appendObj, "\n\t\t", -1); - } - } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", - keyPtr, pcOffset + offset); - } + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclCompileTryCmd -- + * TclCompileVariableCmd -- * - * Procedure called to compile the "try" command. + * Procedure called to compile the "variable" 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 "try" command at + * Instructions are added to envPtr to execute the "variable" command at * runtime. * *---------------------------------------------------------------------- */ int -TclCompileTryCmd( +TclCompileVariableCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ @@ -5085,701 +3752,56 @@ TclCompileTryCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR; - Tcl_Token *bodyToken, *finallyToken, *tokenPtr; - Tcl_Token **handlerTokens = NULL; - Tcl_Obj **matchClauses = NULL; - int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL; - int i; + Tcl_Token *varTokenPtr, *valueTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } - bodyToken = TokenAfter(parsePtr->tokenPtr); - - if (numWords == 2) { - /* - * No handlers or finally; do nothing beyond evaluating the body. - */ - - DefineLineInformation; /* TIP #280 */ - SetLineInformation(1); - CompileBody(envPtr, bodyToken, interp); - return TCL_OK; - } - - numWords -= 2; - tokenPtr = TokenAfter(bodyToken); - /* - * Extract information about what handlers there are. - */ - - numHandlers = numWords >> 2; - numWords -= numHandlers * 4; - if (numHandlers > 0) { - handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers); - matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers); - memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers); - matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers); - resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); - optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); - - for (i=0 ; i<numHandlers ; i++) { - Tcl_Obj *tmpObj, **objv; - int objc; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedToCompile; - } - if (tokenPtr[1].size == 4 - && !strncmp(tokenPtr[1].start, "trap", 4)) { - /* - * Parse the list of errorCode words to match against. - */ - - matchCodes[i] = TCL_ERROR; - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK - || (objc == 0)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL); - matchClauses[i] = tmpObj; - } else if (tokenPtr[1].size == 2 - && !strncmp(tokenPtr[1].start, "on", 2)) { - int code; - static const char *codes[] = { - "ok", "error", "return", "break", "continue", NULL - }; - - /* - * Parse the result code to look for. - */ - - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (Tcl_GetIntFromObj(NULL, tmpObj, &code) != TCL_OK - && Tcl_GetIndexFromObj(NULL, tmpObj, codes, "", - TCL_EXACT, &code) != TCL_OK) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - matchCodes[i] = code; - TclDecrRefCount(tmpObj); - } else { - goto failedToCompile; - } - - /* - * Parse the variable binding. - */ - - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK - || (objc > 2)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (objc > 0) { - int len; - const char *varname = Tcl_GetStringFromObj(objv[0], &len); - - if (!TclIsLocalScalar(varname, len)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - resultVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); - } else { - resultVarIndices[i] = -1; - } - if (objc == 2) { - int len; - const char *varname = Tcl_GetStringFromObj(objv[1], &len); - - if (!TclIsLocalScalar(varname, len)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - optionVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); - } else { - optionVarIndices[i] = -1; - } - TclDecrRefCount(tmpObj); - - /* - * Extract the body for this handler. - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedToCompile; - } - if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') { - handlerTokens[i] = NULL; - } else { - handlerTokens[i] = tokenPtr; - } - - tokenPtr = TokenAfter(tokenPtr); - } - - if (handlerTokens[numHandlers-1] == NULL) { - goto failedToCompile; - } - } - - /* - * Parse the finally clause - */ - - if (numWords == 0) { - finallyToken = NULL; - } else if (numWords == 2) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7 - || strncmp(tokenPtr[1].start, "finally", 7)) { - goto failedToCompile; - } - finallyToken = TokenAfter(tokenPtr); - } else { - goto failedToCompile; - } - - /* - * Issue the bytecode. - */ - - if (finallyToken) { - result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, - numHandlers, matchCodes, matchClauses, resultVarIndices, - optionVarIndices, handlerTokens, finallyToken); - } else { - result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers, - matchCodes, matchClauses, resultVarIndices, optionVarIndices, - handlerTokens); - } - - /* - * Delete any temporary state and finish off. + * Bail out if not compiling a proc body */ - failedToCompile: - if (numHandlers > 0) { - for (i=0 ; i<numHandlers ; i++) { - if (matchClauses[i]) { - TclDecrRefCount(matchClauses[i]); - } - } - TclStackFree(interp, optionVarIndices); - TclStackFree(interp, resultVarIndices); - TclStackFree(interp, matchCodes); - TclStackFree(interp, matchClauses); - TclStackFree(interp, handlerTokens); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * IssueTryInstructions, IssueTryFinallyInstructions -- - * - * The code generators for [try]. Split from the parsing engine for - * reasons of developer sanity, and also split between no-finally and - * with-finally cases because so many of the details of generation vary - * between the two. - * - * The macros below make the instruction issuing easier to follow. - * - *---------------------------------------------------------------------- - */ - -#define OP(name) TclEmitOpcode(INST_##name, envPtr) -#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) -#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) -#define OP44(name,val1,val2) \ - TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) -#define PUSH(str) \ - PushLiteral(envPtr,(str),strlen(str)) -#define JUMP(var,name) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) -#define FIXJUMP(var) \ - TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) - -static int -IssueTryInstructions( - Tcl_Interp *interp, - CompileEnv *envPtr, - Tcl_Token *bodyToken, - int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens) -{ - DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar; - int i, j, len, forwardsNeedFixing = 0; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - char buf[TCL_INTEGER_SPACE]; - - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (resultVar < 0 || optionsVar < 0) { + if (envPtr->procPtr == NULL) { return TCL_ERROR; } /* - * Compile the body, trapping any error in it so that we can trap on it - * and/or run a finally clause. Note that there must be at least one - * on/trap clause; when none is present, this whole function is not called - * (and it's never called when there's a finally clause). - */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); - OP1( JUMP1, 3); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP4( STORE_SCALAR4, resultVar); - OP( POP); - OP( PUSH_RETURN_OPTIONS); - OP4( STORE_SCALAR4, optionsVar); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - - /* - * Now we handle all the registered 'on' and 'trap' handlers in order. - * For us to be here, there must be at least one handler. - * - * Slight overallocation, but reduces size of this function. + * Loop over the (var, value) pairs. */ - addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - - for (i=0 ; i<numHandlers ; i++) { - sprintf(buf, "%d", matchCodes[i]); - OP( DUP); - PUSH( buf); - OP( EQ); - JUMP(notCodeJumpSource, JUMP_FALSE4); - if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); - - /* - * Match the errorcode according to try/trap rules. - */ - - OP4( LOAD_SCALAR4, optionsVar); - PUSH( "-errorcode"); - OP4( DICT_GET, 1); - OP44( LIST_RANGE_IMM, 0, len-1); - PUSH( TclGetString(matchClauses[i])); - OP( STR_EQ); - JUMP(notECJumpSource, JUMP_FALSE4); - } else { - notECJumpSource = -1; /* LINT */ - } - OP( POP); - - /* - * There is no finally clause, so we can avoid wrapping a catch - * context around the handler. That simplifies what instructions need - * to be issued a lot since we can let errors just fall through. - */ + valueTokenPtr = parsePtr->tokenPtr; + for (i=2; i<=numWords; i+=2) { + varTokenPtr = TokenAfter(valueTokenPtr); + valueTokenPtr = TokenAfter(varTokenPtr); - if (resultVars[i] >= 0) { - OP4( LOAD_SCALAR4, resultVar); - OP4( STORE_SCALAR4, resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - OP4( LOAD_SCALAR4, optionsVar); - OP4( STORE_SCALAR4, optionVars[i]); - OP( POP); - } - } - if (!handlerTokens[i]) { - forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); - } else { - forwardsToFix[i] = -1; - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - for (j=0 ; j<i ; j++) { - if (forwardsToFix[j] == -1) { - continue; - } - FIXJUMP(forwardsToFix[j]); - forwardsToFix[j] = -1; - } - } - BODY( handlerTokens[i], 5+i*4); - } + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - JUMP(addrsToFix[i], JUMP4); - if (matchClauses[i]) { - FIXJUMP(notECJumpSource); + if (localIndex < 0) { + return TCL_ERROR; } - FIXJUMP(notCodeJumpSource); - } - /* - * Drop the result code since it didn't match any clause, and reissue the - * exception. Note also that INST_RETURN_STK can proceed to the next - * instruction. - */ - - OP( POP); - OP4( LOAD_SCALAR4, optionsVar); - OP4( LOAD_SCALAR4, resultVar); - OP( RETURN_STK); - - /* - * Fix all the jumps from taken clauses to here (which is the end of the - * [try]). - */ - - for (i=0 ; i<numHandlers ; i++) { - FIXJUMP(addrsToFix[i]); - } - TclStackFree(interp, forwardsToFix); - TclStackFree(interp, addrsToFix); - return TCL_OK; -} - -static int -IssueTryFinallyInstructions( - Tcl_Interp *interp, - CompileEnv *envPtr, - Tcl_Token *bodyToken, - int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens, - Tcl_Token *finallyToken) /* Not NULL */ -{ - DefineLineInformation; /* TIP #280 */ - int savedStackDepth = envPtr->currStackDepth; - int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - char buf[TCL_INTEGER_SPACE]; - - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (resultVar < 0 || optionsVar < 0) { - return TCL_ERROR; - } - - /* - * Compile the body, trapping any error in it so that we can trap on it - * (if any trap matches) and run a finally clause. - */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); - OP1( JUMP1, 3); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP4( STORE_SCALAR4, resultVar); - OP( POP); - OP( PUSH_RETURN_OPTIONS); - OP4( STORE_SCALAR4, optionsVar); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - envPtr->currStackDepth = savedStackDepth + 1; - - /* - * Now we handle all the registered 'on' and 'trap' handlers in order. - */ - - if (numHandlers) { - /* - * Slight overallocation, but reduces size of this function. - */ - - addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - - for (i=0 ; i<numHandlers ; i++) { - sprintf(buf, "%d", matchCodes[i]); - OP( DUP); - PUSH( buf); - OP( EQ); - JUMP(notCodeJumpSource, JUMP_FALSE4); - if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); - - /* - * Match the errorcode according to try/trap rules. - */ - - OP4( LOAD_SCALAR4, optionsVar); - PUSH( "-errorcode"); - OP4( DICT_GET, 1); - OP44( LIST_RANGE_IMM, 0, len-1); - PUSH( TclGetString(matchClauses[i])); - OP( STR_EQ); - JUMP(notECJumpSource, JUMP_FALSE4); - } else { - notECJumpSource = -1; /* LINT */ - } + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); + if (i != numWords) { /* - * There is a finally clause, so we need a fairly complex sequence - * of instructions to deal with an on/trap handler because we must - * call the finally handler *and* we need to substitute the result - * from a failed trap for the result from the main script. + * A value has been given: set the variable, pop the value */ - if (resultVars[i] >= 0 || handlerTokens[i]) { - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - } - if (resultVars[i] >= 0) { - OP4( LOAD_SCALAR4, resultVar); - OP4( STORE_SCALAR4, resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - OP4( LOAD_SCALAR4, optionsVar); - OP4( STORE_SCALAR4, optionVars[i]); - OP( POP); - } - } - if (!handlerTokens[i]) { - /* - * No handler. Will not be the last handler (that condition is - * checked by the caller). Chain to the next one. - */ - - ExceptionRangeEnds(envPtr, range); - forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); - if (resultVars[i] >= 0) { - goto finishTrapCatchHandling; - } - } else { - /* - * Got a handler. Make sure that any pending patch-up actions - * from previous unprocessed handlers are dealt with now that - * we know where they are to jump to. - */ - - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - OP1( JUMP1, 7); - for (j=0 ; j<i ; j++) { - if (forwardsToFix[j] == -1) { - continue; - } - FIXJUMP(forwardsToFix[j]); - forwardsToFix[j] = -1; - } - OP4( BEGIN_CATCH4, range); - } - BODY( handlerTokens[i], 5+i*4); - ExceptionRangeEnds(envPtr, range); - OP( POP); - OP1( JUMP1, 6); - forwardsToFix[i] = -1; - - /* - * Error in handler or setting of variables; replace the - * stored exception with the new one. Note that we only push - * this if we have either a body or some variable setting - * here. Otherwise this code is unreachable. - */ - - finishTrapCatchHandling: - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP4( STORE_SCALAR4, resultVar); - OP( POP); - OP( PUSH_RETURN_OPTIONS); - OP4( STORE_SCALAR4, optionsVar); - OP( POP); - OP( END_CATCH); - } - if (i+1 < numHandlers) { - JUMP(addrsToFix[i], JUMP4); - } - if (matchClauses[i]) { - FIXJUMP(notECJumpSource); - } - FIXJUMP(notCodeJumpSource); - } - - /* - * Fix all the jumps from taken clauses to here (the start of the - * finally clause). - */ - - for (i=0 ; i<numHandlers-1 ; i++) { - FIXJUMP(addrsToFix[i]); + CompileWord(envPtr, valueTokenPtr, interp, 1); + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); } - TclStackFree(interp, forwardsToFix); - TclStackFree(interp, addrsToFix); } /* - * Drop the result code. - */ - - OP( POP); - envPtr->currStackDepth = savedStackDepth; - - /* - * Process the finally clause (at last!) Note that we do not wrap this in - * error handlers because we would just rethrow immediately anyway. Then - * (on normal success) we reissue the exception. Note also that - * INST_RETURN_STK can proceed to the next instruction; that'll be the - * next command (or some inter-command manipulation). + * Set the result to empty */ - BODY( finallyToken, 3 + 4*numHandlers); - OP( POP); - OP4( LOAD_SCALAR4, optionsVar); - OP4( LOAD_SCALAR4, resultVar); - OP( RETURN_STK); - - return TCL_OK; -} - -#undef OP -#undef OP1 -#undef OP4 -#undef OP44 -#undef BODY -#undef PUSH -#undef JUMP -#undef FIXJUMP - -/* - *---------------------------------------------------------------------- - * - * TclCompileUnsetCmd -- - * - * Procedure called to compile the "unset" 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 "unset" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileUnsetCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int isScalar, simpleVarName, localIndex, numWords, flags, i; - Tcl_Obj *leadingWord; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords-1; - flags = 1; - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { - int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); - - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; - } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ - - return TCL_ERROR; - } - TclDecrRefCount(leadingWord); - - for (i=0 ; i<numWords ; i++) { - /* - * 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. - */ - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - /* - * Emit instructions to unset the variable. - */ - - if (!simpleVarName) { - TclEmitInstInt1( INST_UNSET_STK, flags, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitInstInt1(INST_UNSET_STK, flags, envPtr); - } else { - TclEmitInstInt1(INST_UNSET_SCALAR, flags, envPtr); - TclEmitInt4( localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags, envPtr); - } else { - TclEmitInstInt1(INST_UNSET_ARRAY, flags, envPtr); - TclEmitInt4( localIndex, envPtr); - } - } - - varTokenPtr = TokenAfter(varTokenPtr); - } PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -5787,180 +3809,97 @@ TclCompileUnsetCmd( /* *---------------------------------------------------------------------- * - * TclCompileWhileCmd -- + * IndexTailVarIfKnown -- * - * Procedure called to compile the "while" command. + * Procedure used in compiling [global] and [variable] commands. It + * inspects the variable name described by varTokenPtr and, if the tail + * is known at compile time, defines a corresponding local variable. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * Returns the variable's index in the table of compiled locals if the + * tail is known at compile time, or -1 otherwise. * * Side effects: - * Instructions are added to envPtr to execute the "while" command at - * runtime. + * None. * *---------------------------------------------------------------------- */ -int -TclCompileWhileCmd( - 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 defintion of command being - * compiled. */ +static int +IndexTailVarIfKnown( + Tcl_Interp *interp, + Tcl_Token *varTokenPtr, /* Token representing the variable name */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *testTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; - int savedStackDepth = envPtr->currStackDepth; - int loopMayEnd = 1; /* This is set to 0 if it is recognized as an - * infinite loop. */ - Tcl_Obj *boolObj; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } + Tcl_Obj *tailPtr; + const char *tailName, *p; + int len, n = varTokenPtr->numComponents; + Tcl_Token *lastTokenPtr; + int full, localIndex; /* - * If the test expression requires substitutions, don't compile the while - * command inline. E.g., the expression might cause the loop to never - * execute or execute forever, as in "while "$x < 5" {}". + * 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. * - * Bail out also if the body expression requires substitutions in order to - * insure correct behaviour [Bug 219166] + * 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. */ - testTokenPtr = TokenAfter(parsePtr->tokenPtr); - bodyTokenPtr = TokenAfter(testTokenPtr); - - if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_ERROR; + if (!EnvHasLVT(envPtr)) { + return -1; } - /* - * Find out if the condition is a constant. - */ + TclNewObj(tailPtr); + if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { + full = 1; + lastTokenPtr = varTokenPtr; + } else { + full = 0; + lastTokenPtr = varTokenPtr + n; + if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { + Tcl_DecrRefCount(tailPtr); + return -1; + } + } - boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); - Tcl_IncrRefCount(boolObj); - code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); - if (code == TCL_OK) { - if (boolVal) { - /* - * It is an infinite loop; flag it so that we generate a more - * efficient body. - */ + tailName = TclGetStringFromObj(tailPtr, &len); - loopMayEnd = 0; - } else { + if (len) { + if (*(tailName+len-1) == ')') { /* - * This is an empty loop: "while 0 {...}" or such. Compile no - * bytecodes. + * Possible array: bail out */ - goto pushResult; + Tcl_DecrRefCount(tailPtr); + return -1; } - } - - /* - * Create a ExceptionRange record for the loop body. This is used to - * implement break and continue. - */ - - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - - /* - * Jump to the evaluation of the condition. This code uses the "loop - * rotation" optimisation (which eliminates one branch from the loop). - * "while cond body" produces then: - * goto A - * B: body : bodyCodeOffset - * A: cond -> result : testCodeOffset, continueOffset - * if (result) goto B - * - * The infinite loop "while 1 body" produces: - * B: body : all three offsets here - * goto B - */ - if (loopMayEnd) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpEvalCondFixup); - testCodeOffset = 0; /* Avoid compiler warning. */ - } else { /* - * Make sure that the first command in the body is preceded by an - * INST_START_CMD, and hence counted properly. [Bug 1752146] + * Get the tail: immediately after the last '::' */ - envPtr->atCmdStart = 0; - testCodeOffset = CurrentOffset(envPtr); - } - - /* - * Compile the loop body. - */ - - SetLineInformation(2); - bodyCodeOffset = ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); - ExceptionRangeEnds(envPtr, range); - envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode(INST_POP, envPtr); - - /* - * Compile the test expression then emit the conditional jump that - * terminates the while. We already know it's a simple word. - */ - - if (loopMayEnd) { - testCodeOffset = CurrentOffset(envPtr); - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { - bodyCodeOffset += 3; - testCodeOffset += 3; + for (p = tailName + len -1; p > tailName; p--) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; + break; + } } - envPtr->currStackDepth = savedStackDepth; - SetLineInformation(1); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; + if (!full && (p == tailName)) { + /* + * No :: in the last component. + */ - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } - } else { - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); + Tcl_DecrRefCount(tailPtr); + return -1; } + len -= p - tailName; + tailName = p; } - /* - * Set the loop's body, continue and break offsets. - */ - - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - ExceptionRangeTarget(envPtr, range, breakOffset); - - /* - * The while command's result is an empty string. - */ - - pushResult: - envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); - return TCL_OK; + localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); + Tcl_DecrRefCount(tailPtr); + return localIndex; } /* @@ -6204,1111 +4143,6 @@ PushVarName( } /* - *---------------------------------------------------------------------- - * - * CompileUnaryOpCmd -- - * - * Utility routine to compile the unary operator commands. - * - * 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 compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileUnaryOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int instruction, - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode(instruction, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileAssociativeBinaryOpCmd -- - * - * Utility routine to compile the binary operator commands that accept an - * arbitrary number of arguments, and that are associative operations. - * Because of the associativity, we may combine operations from right to - * left, saving us any effort of re-ordering the arguments on the stack - * after substitutions are completed. - * - * 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 compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileAssociativeBinaryOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - const char *identity, - int instruction, - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, identity, -1); - words++; - } - if (words > 3) { - /* - * Reverse order of arguments to get precise agreement with [expr] in - * calcuations, including roundoff errors. - */ - - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - } - while (--words > 1) { - TclEmitOpcode(instruction, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileStrictlyBinaryOpCmd -- - * - * Utility routine to compile the binary operator commands, that strictly - * accept exactly two arguments. - * - * 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 compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileStrictlyBinaryOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int instruction, - CompileEnv *envPtr) -{ - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - return CompileAssociativeBinaryOpCmd(interp, parsePtr, - NULL, instruction, envPtr); -} - -/* - *---------------------------------------------------------------------- - * - * CompileComparisonOpCmd -- - * - * Utility routine to compile the n-ary comparison operator commands. - * - * 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 compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileComparisonOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int instruction, - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords < 3) { - PushLiteral(envPtr, "1", 1); - } else if (parsePtr->numWords == 3) { - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(instruction, envPtr); - } else if (envPtr->procPtr == NULL) { - /* - * No local variable space! - */ - - return TCL_ERROR; - } else { - int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); - int words; - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(instruction, envPtr); - for (words=3 ; words<parsePtr->numWords ;) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); - } - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - if (++words < parsePtr->numWords) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - } - TclEmitOpcode(instruction, envPtr); - } - for (; words>3 ; words--) { - TclEmitOpcode(INST_BITAND, envPtr); - } - - /* - * Drop the value from the temp variable; retaining that reference - * might be expensive elsewhere. - */ - - PushLiteral(envPtr, "", 0); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompile*OpCmd -- - * - * Procedures called to compile the corresponding "::tcl::mathop::*" - * commands. These are all wrappers around the utility operator command - * compiler functions, except for the compilers for subtraction and - * division, which are special. - * - * 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 compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInvertOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr); -} - -int -TclCompileNotOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr); -} - -int -TclCompileAddOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD, - envPtr); -} - -int -TclCompileMulOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT, - envPtr); -} - -int -TclCompileAndOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND, - envPtr); -} - -int -TclCompileOrOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR, - envPtr); -} - -int -TclCompileXorOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR, - envPtr); -} - -int -TclCompilePowOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - /* - * This one has its own implementation because the ** operator is the only - * one with right associativity. - */ - - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, "1", 1); - words++; - } - while (--words > 1) { - TclEmitOpcode(INST_EXPON, envPtr); - } - return TCL_OK; -} - -int -TclCompileLshiftOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr); -} - -int -TclCompileRshiftOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr); -} - -int -TclCompileModOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr); -} - -int -TclCompileNeqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr); -} - -int -TclCompileStrneqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr); -} - -int -TclCompileInOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr); -} - -int -TclCompileNiOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN, - envPtr); -} - -int -TclCompileLessOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr); -} - -int -TclCompileLeqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr); -} - -int -TclCompileGreaterOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr); -} - -int -TclCompileGeqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr); -} - -int -TclCompileEqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr); -} - -int -TclCompileStreqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr); -} - -int -TclCompileMinusOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - /* Fallback to direct eval to report syntax error */ - return TCL_ERROR; - } - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (words == 2) { - TclEmitOpcode(INST_UMINUS, envPtr); - return TCL_OK; - } - if (words == 3) { - TclEmitOpcode(INST_SUB, envPtr); - return TCL_OK; - } - - /* - * Reverse order of arguments to get precise agreement with [expr] in - * calcuations, including roundoff errors. - */ - - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_SUB, envPtr); - } - return TCL_OK; -} - -int -TclCompileDivOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - /* Fallback to direct eval to report syntax error */ - return TCL_ERROR; - } - if (parsePtr->numWords == 2) { - PushLiteral(envPtr, "1.0", 3); - } - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (words <= 3) { - TclEmitOpcode(INST_DIV, envPtr); - return TCL_OK; - } - - /* - * Reverse order of arguments to get precise agreement with [expr] in - * calcuations, including roundoff errors. - */ - - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_DIV, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * IndexTailVarIfKnown -- - * - * Procedure used in compiling [global] and [variable] commands. It - * inspects the variable name described by varTokenPtr and, if the tail - * is known at compile time, defines a corresponding local variable. - * - * Results: - * Returns the variable's index in the table of compiled locals if the - * tail is known at compile time, or -1 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -IndexTailVarIfKnown( - Tcl_Interp *interp, - Tcl_Token *varTokenPtr, /* Token representing the variable name */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Obj *tailPtr; - const char *tailName, *p; - int len, n = varTokenPtr->numComponents; - 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 (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { - Tcl_DecrRefCount(tailPtr); - return -1; - } - } - - 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 == ':') && (*(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; -} - -/* - *---------------------------------------------------------------------- - * - * 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. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); - - if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords < 3) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Push the frame index if it is known at compile time - */ - - 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; - } - CompileWord(envPtr, tokenPtr, interp, 1); - otherTokenPtr = TokenAfter(tokenPtr); - i = 4; - } else { - if (!(numWords%2)) { - return TCL_ERROR; - } - PushLiteral(envPtr, "1", 1); - otherTokenPtr = tokenPtr; - i = 3; - } - } 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 (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); - } - - /* - * Pop the frame index, and set the result to empty - */ - - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNamespaceCmd -- - * - * Procedure called to compile the "namespace" command; currently, only - * the subcommand "namespace upvar" is compiled to bytecodes. - * - * 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 -TclCompileNamespaceCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Only compile [namespace upvar ...]: needs an odd number of args, >=5 - */ - - numWords = parsePtr->numWords; - if (!(numWords%2) || (numWords < 5)) { - return TCL_ERROR; - } - - /* - * Check if the second argument is "upvar" - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */ - || strncmp(tokenPtr->start, "upvar", 5)) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - tokenPtr = TokenAfter(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=4; i<=numWords; i+=2) { - otherTokenPtr = TokenAfter(localTokenPtr); - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - 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 - */ - - PushLiteral(envPtr, "::", 2); - - /* - * Loop over the variables. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if (localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileVariableCmd -- - * - * Procedure called to compile the "variable" 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 "variable" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileVariableCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - 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=2; i<=numWords; i+=2) { - varTokenPtr = TokenAfter(valueTokenPtr); - valueTokenPtr = TokenAfter(varTokenPtr); - - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if (localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); - - if (i != numWords) { - /* - * A value has been given: set the variable, pop the value - */ - - CompileWord(envPtr, valueTokenPtr, interp, 1); - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); - TclEmitOpcode(INST_POP, envPtr); - } - } - - /* - * Set the result to empty - */ - - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileInfoExistsCmd -- - * - * Procedure called to compile the "info exists" subcommand. - * - * 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 exists" - * subcommand at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInfoExistsCmd( - 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 defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int isScalar, simpleVarName, localIndex; - DefineLineInformation; /* TIP #280 */ - - 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, - &simpleVarName, &isScalar, 1); - - /* - * Emit instruction to check the variable for existence. - */ - - if (simpleVarName) { - 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); - } - } - } else { - TclEmitOpcode(INST_EXIST_STK, envPtr); - } - - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 |