diff options
Diffstat (limited to 'generic/tclCompCmds.c')
| -rw-r--r-- | generic/tclCompCmds.c | 6532 |
1 files changed, 4709 insertions, 1823 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5f4c298..3b234b0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -7,7 +7,7 @@ * Copyright (c) 1997-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2013 by Donal K. Fellows. + * Copyright (c) 2004-2006 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,7 +15,123 @@ #include "tclInt.h" #include "tclCompile.h" -#include <assert.h> + +/* + * Macro that encapsulates an efficiency trick that avoids a function call for + * the simplest of compiles. The ANSI C "prototype" for this macro is: + * + * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp, int word); + */ + +#define CompileWord(envPtr, tokenPtr, interp, word) \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ + (tokenPtr)[1].size), (envPtr)); \ + } else { \ + envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); \ + } + +/* + * TIP #280: Remember the per-word line information of the current command. An + * index is used instead of a pointer as recursive compilation may reallocate, + * i.e. move, the array. This is also the reason to save the nuloc now, it may + * change during the course of the function. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \ + envPtr->clNext = mapPtr->loc [eclIndex].next [(word)] + +/* + * Convenience macro for use when compiling bodies of commands. The ANSI C + * "prototype" for this macro is: + * + * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileBody(envPtr, tokenPtr, interp) \ + TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)) + +/* + * Convenience macro for use when compiling tokens to be pushed. The ANSI C + * "prototype" for this macro is: + * + * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileTokens(envPtr, tokenPtr, interp) \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); +/* + * Convenience macro for use when pushing literals. The ANSI C "prototype" for + * this macro is: + * + * static void PushLiteral(CompileEnv *envPtr, + * const char *string, int length); + */ + +#define PushLiteral(envPtr, string, length) \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + +/* + * Macro to advance to the next token; it is more mnemonic than the address + * arithmetic that it replaces. The ANSI C "prototype" for this macro is: + * + * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr); + */ + +#define TokenAfter(tokenPtr) \ + ((tokenPtr) + ((tokenPtr)->numComponents + 1)) + +/* + * Macro to get the offset to the next instruction to be issued. The ANSI C + * "prototype" for this macro is: + * + * static int CurrentOffset(CompileEnv *envPtr); + */ + +#define CurrentOffset(envPtr) \ + ((envPtr)->codeNext - (envPtr)->codeStart) + +/* + * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the + * maximal depth of nested CATCH ranges in order to alloc runtime + * memory. These macros should compute precisely that? OTOH, the nesting depth + * of LOOP ranges is an interesting datum for debugging purposes, and that is + * what we compute now. + * + * static int DeclareExceptionRange(CompileEnv *envPtr, int type); + * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); + */ + +#define DeclareExceptionRange(envPtr, type) \ + (TclCreateExceptRange((type), (envPtr))) +#define ExceptionRangeStarts(envPtr, index) \ + (((envPtr)->exceptDepth++), \ + ((envPtr)->maxExceptDepth = \ + TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ + ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) +#define ExceptionRangeEnds(envPtr, index) \ + (((envPtr)->exceptDepth--), \ + ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ + CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) +#define ExceptionRangeTarget(envPtr, index, targetType) \ + ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) /* * Prototypes for procedures defined later in this file: @@ -26,101 +142,88 @@ static void FreeDictUpdateInfo(ClientData clientData); static void PrintDictUpdateInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static void DisassembleDictUpdateInfo(ClientData clientData, - Tcl_Obj *dictObj, ByteCode *codePtr, - unsigned int pcOffset); static ClientData DupForeachInfo(ClientData clientData); static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static void DisassembleForeachInfo(ClientData clientData, - Tcl_Obj *dictObj, ByteCode *codePtr, - unsigned int pcOffset); -static void PrintNewForeachInfo(ClientData clientData, +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 DisassembleNewForeachInfo(ClientData clientData, - Tcl_Obj *dictObj, ByteCode *codePtr, - unsigned int pcOffset); -static int CompileEachloopCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - CompileEnv *envPtr, int collect); -static int CompileDictEachCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr, int collect); +static int LocalScalarFromToken(Tcl_Token *tokenPtr, + CompileEnv *envPtr); +static int LocalScalar(const char *bytes, int numBytes, + 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); + +#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ + PushVarName (i,v,e,f,l,s,sc, \ + mapPtr->loc [eclIndex].line [(word)], \ + mapPtr->loc [eclIndex].next [(word)]) + +/* + * Flags bits used by PushVarName. + */ + +#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ +#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. */ -static const AuxDataType foreachInfoType = { +AuxDataType tclForeachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ - PrintForeachInfo, /* printProc */ - DisassembleForeachInfo /* disassembleProc */ + PrintForeachInfo /* printProc */ }; -static const AuxDataType newForeachInfoType = { - "NewForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo, /* freeProc */ - PrintNewForeachInfo, /* printProc */ - DisassembleNewForeachInfo /* disassembleProc */ +AuxDataType tclJumptableInfoType = { + "JumptableInfo", /* name */ + DupJumptableInfo, /* dupProc */ + FreeJumptableInfo, /* freeProc */ + PrintJumptableInfo /* printProc */ }; -static const AuxDataType dictUpdateInfoType = { +AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo, /* printProc */ - DisassembleDictUpdateInfo /* disassembleProc */ + PrintDictUpdateInfo /* printProc */ }; /* *---------------------------------------------------------------------- * - * TclGetAuxDataType -- - * - * This procedure looks up an Auxdata type by name. - * - * Results: - * If an AuxData type with name matching "typeName" is found, a pointer - * to its AuxDataType structure is returned; otherwise, NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -const AuxDataType * -TclGetAuxDataType( - const char *typeName) /* Name of AuxData type to look up. */ -{ - if (!strcmp(typeName, foreachInfoType.name)) { - return &foreachInfoType; - } else if (!strcmp(typeName, newForeachInfoType.name)) { - return &newForeachInfoType; - } else if (!strcmp(typeName, dictUpdateInfoType.name)) { - return &dictUpdateInfoType; - } else if (!strcmp(typeName, tclJumptableInfoType.name)) { - return &tclJumptableInfoType; - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * * TclCompileAppendCmd -- * * Procedure called to compile the "append" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 "append" command at @@ -139,10 +242,9 @@ TclCompileAppendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i; + int simpleVarName, isScalar, localIndex, numWords; DefineLineInformation; /* TIP #280 */ - /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -154,11 +256,10 @@ TclCompileAppendCmd( return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); } else if (numWords > 3) { /* - * APPEND instructions currently only handle one value, but we can - * handle some multi-value cases by stringing them together. + * APPEND instructions currently only handle one value. */ - goto appendMultiple; + return TCL_ERROR; } /* @@ -171,8 +272,8 @@ TclCompileAppendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so @@ -180,313 +281,37 @@ TclCompileAppendCmd( * each argument. */ + if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); + } /* * Emit instructions to set/get the variable. */ + if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); } else { - Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); } else { - Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); } } - - return TCL_OK; - - appendMultiple: - /* - * Can only handle the case where we are appending to a local scalar when - * there are multiple values to append. Fortunately, this is common. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - localIndex = LocalScalarFromToken(varTokenPtr, envPtr); - if (localIndex < 0) { - return TCL_ERROR; - } - - /* - * Definitely appending to a local scalar; generate the words and append - * them. - */ - - valueTokenPtr = TokenAfter(varTokenPtr); - for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); - } - TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr); - for (i = 2 ; i < numWords ;) { - Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr); - if (++i < numWords) { - TclEmitOpcode(INST_POP, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileArray*Cmd -- - * - * Functions called to compile "array" sucommands. - * - * Results: - * All return TCL_OK for a successful compile, and TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "array" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileArrayExistsCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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 isScalar, localIndex; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { - return TCL_ERROR; - } - - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); } else { - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - } - return TCL_OK; -} - -int -TclCompileArraySetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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 *varTokenPtr, *dataTokenPtr; - int isScalar, localIndex, code = TCL_OK; - int isDataLiteral, isDataValid, isDataEven, len; - int keyVar, valVar, infoIndex; - int fwd, offsetBack, offsetFwd; - Tcl_Obj *literalObj; - ForeachInfo *infoPtr; - - if (parsePtr->numWords != 3) { - return TCL_ERROR; + TclEmitOpcode(INST_APPEND_STK, envPtr); } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - dataTokenPtr = TokenAfter(varTokenPtr); - literalObj = Tcl_NewObj(); - isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); - isDataValid = (isDataLiteral - && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); - isDataEven = (isDataValid && (len & 1) == 0); - - /* - * Special case: literal odd-length argument is always an error. - */ - - if (isDataValid && !isDataEven) { - PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); - goto done; - } - - /* - * Except for the special "ensure array" case below, when we're not in - * a proc, we cannot do a better compile than generic. - */ - - if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || - (envPtr->procPtr == NULL && !(isDataEven && len == 0))) { - code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - goto done; - } - - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { - code = TCL_ERROR; - goto done; - } - - /* - * Special case: literal empty value argument is just an "ensure array" - * operation. - */ - - if (isDataEven && len == 0) { - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); - /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - PushStringLiteral(envPtr, ""); - goto done; - } - - if (localIndex < 0) { - /* - * a non-local variable: upvar from a local one! This consumes the - * variable name that was left at stacktop. - */ - - localIndex = TclFindCompiledLocal(varTokenPtr->start, - varTokenPtr->size, 1, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); - TclEmitOpcode(INST_POP, envPtr); - } - - /* - * Prepare for the internal foreach. - */ - - keyVar = AnonymousLocal(envPtr); - valVar = AnonymousLocal(envPtr); - - infoPtr = ckalloc(sizeof(ForeachInfo)); - infoPtr->numLists = 1; - infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); - infoPtr->varLists[0]->numVars = 2; - infoPtr->varLists[0]->varIndexes[0] = keyVar; - infoPtr->varLists[0]->varIndexes[1] = valVar; - infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); - - /* - * Start issuing instructions to write to the array. - */ - - CompileWord(envPtr, dataTokenPtr, interp, 2); - if (!isDataLiteral || !isDataValid) { - /* - * Only need this safety check if we're handling a non-literal or list - * containing an invalid literal; with valid list literals, we've - * already checked (worth it because literals are a very common - * use-case with [array set]). - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - PushStringLiteral(envPtr, "1"); - TclEmitOpcode( INST_BITAND, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); - TclAdjustStackDepth(-1, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - } - - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ - TclEmitOpcode( INST_FOREACH_STEP, envPtr); - TclEmitOpcode( INST_FOREACH_END, envPtr); - TclAdjustStackDepth(-3, envPtr); - PushStringLiteral(envPtr, ""); - - done: - Tcl_DecrRefCount(literalObj); - return code; -} - -int -TclCompileArrayUnsetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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 = TokenAfter(parsePtr->tokenPtr); - int isScalar, localIndex; - - if (parsePtr->numWords != 2) { - return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { - return TCL_ERROR; - } - - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); - TclEmitInt4( localIndex, envPtr); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); - TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); - /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -498,8 +323,8 @@ TclCompileArrayUnsetCmd( * Procedure called to compile the "break" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 "break" command at @@ -517,34 +342,15 @@ TclCompileBreakCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - ExceptionRange *rangePtr; - ExceptionAux *auxPtr; - if (parsePtr->numWords != 1) { return TCL_ERROR; } /* - * Find the innermost exception range that contains this command. + * Emit a break instruction. */ - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - /* - * Found the target! No need for a nasty INST_BREAK here. - */ - - TclCleanupStackForBreakContinue(envPtr, auxPtr); - TclAddLoopBreakFixup(envPtr, auxPtr); - } else { - /* - * Emit a real break. - */ - - TclEmitOpcode(INST_BREAK, envPtr); - } - TclAdjustStackDepth(1, envPtr); - + TclEmitOpcode(INST_BREAK, envPtr); return TCL_OK; } @@ -577,9 +383,10 @@ TclCompileCatchCmd( { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range, dropScript = 0; + int resultIndex, optsIndex, range; + int initStackDepth = envPtr->currStackDepth; + int savedStackDepth; DefineLineInformation; /* TIP #280 */ - int depth = TclGetStackDepth(envPtr); /* * If syntax does not match what we expect for [catch], do not compile. @@ -591,15 +398,6 @@ TclCompileCatchCmd( } /* - * If variables were specified and the catch command is at global level - * (not in a procedure), don't compile it inline: the payoff is too small. - */ - - if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { - return TCL_ERROR; - } - - /* * Make sure the variable names, if any, have no substitutions and just * refer to local scalars. */ @@ -608,13 +406,11 @@ TclCompileCatchCmd( cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); - /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); if (resultIndex < 0) { return TCL_ERROR; } - /* DKF */ if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); @@ -625,199 +421,148 @@ TclCompileCatchCmd( } /* - * We will compile the catch command. Declare the exception range that it - * uses. - * + * We will compile the catch command. Declare the exception range + * that it uses. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + + /* * If the body is a simple word, compile a BEGIN_CATCH instruction, * followed by the instructions to eval the body. * Otherwise, compile instructions to substitute the body text before - * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the - * substituted body. - * Care has to be taken to make sure that substitution happens outside the - * catch range so that errors in the substitution are not caught. + * starting the catch, then BEGIN_CATCH, and then EVAL_STK to + * evaluate the substituted body. + * Care has to be taken to make sure that substitution happens outside + * the catch range so that errors in the substitution are not caught. * [Bug 219184] * The reason for duplicating the script is that EVAL_STK would otherwise * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - BODY(cmdTokenPtr, 1); + CompileBody(envPtr, cmdTokenPtr, interp); } else { - SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInvoke(envPtr, INST_EVAL_STK); - /* drop the script */ - dropScript = 1; - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode(INST_DUP, envPtr); + TclEmitOpcode(INST_EVAL_STK, envPtr); } - ExceptionRangeEnds(envPtr, range); - + /* Stack at this point: + * nonsimple: script <mark> result + * simple: <mark> result + */ /* - * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, - * and jump around the "error case" code. + * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch + * result, and jump around the "error case" code. */ - TclCheckStackDepth(depth+1, envPtr); - PushStringLiteral(envPtr, "0"); + PushLiteral(envPtr, "0", 1); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + /* Stack at this point: ?script? <mark> result TCL_OK */ /* - * Emit the "error case" epilogue. Push the interpreter result and the - * return code. + * Emit the "error case" epilogue. Push the interpreter result + * and the return code. */ + envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); - TclSetStackDepth(depth + dropScript, envPtr); - - if (dropScript) { - TclEmitOpcode( INST_POP, envPtr); - } - - - /* Stack at this point is empty */ - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); + /* Stack at this point: ?script? */ + TclEmitOpcode(INST_PUSH_RESULT, envPtr); + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - /* Stack at this point on both branches: result returnCode */ + /* + * Update the target of the jump after the "no errors" code. + */ + /* Stack at this point: ?script? result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - /* - * Push the return options if the caller wants them. This needs to happen - * before INST_END_CATCH - */ + /* Push the return options if the caller wants them */ if (optsIndex != -1) { - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); } /* * End the catch */ - TclEmitOpcode( INST_END_CATCH, envPtr); + ExceptionRangeEnds(envPtr, range); + TclEmitOpcode(INST_END_CATCH, envPtr); /* - * Save the result and return options if the caller wants them. This needs - * to happen after INST_END_CATCH (compile-3.6/7). + * At this point, the top of the stack is inconveniently ordered: + * ?script? result returnCode ?returnOptions? + * Reverse the stack to bring the result to the top. */ if (optsIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4(INST_REVERSE, 3, envPtr); + } else { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); } /* - * At this point, the top of the stack is inconveniently ordered: - * result returnCode - * Reverse the stack to store the result. + * Store the result if requested, and remove it from the stack */ - TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (resultIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); - } - TclEmitOpcode( INST_POP, envPtr); - - TclCheckStackDepth(depth+1, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileConcatCmd -- - * - * Procedure called to compile the "concat" 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 "concat" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileConcatCmd( - 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_Obj *objPtr, *listObj; - Tcl_Token *tokenPtr; - int i; - - /* TODO: Consider compiling expansion case. */ - if (parsePtr->numWords == 1) { - /* - * [concat] without arguments just pushes an empty object. - */ - - PushStringLiteral(envPtr, ""); - return TCL_OK; + if (resultIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); + } } + TclEmitOpcode(INST_POP, envPtr); /* - * Test if all arguments are compile-time known. If they are, we can - * implement with a simple push. + * Stack is now ?script? ?returnOptions? returnCode. + * If the options dict has been requested, it is buried on the stack + * under the return code. Reverse the stack to bring it to the top, + * store it and remove it from the stack. */ - listObj = Tcl_NewObj(); - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { - tokenPtr = TokenAfter(tokenPtr); - objPtr = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(listObj); - listObj = NULL; - break; + if (optsIndex != -1) { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + if (optsIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); } - (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); - } - if (listObj != NULL) { - Tcl_Obj **objs; - const char *bytes; - int len; - - Tcl_ListObjGetElements(NULL, listObj, &len, &objs); - objPtr = Tcl_ConcatObj(len, objs); - Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &len); - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(objPtr); - return TCL_OK; + TclEmitOpcode(INST_POP, envPtr); } /* - * General case: runtime concat. + * Stack is now ?script? result. Get rid of the subst'ed script + * if it's hanging arond. */ - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitOpcode(INST_POP, envPtr); } - TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); + /* + * Result of all this, on either branch, should have been to leave + * one operand -- the return code -- on the stack. + */ + if (envPtr->currStackDepth != initStackDepth + 1) { + Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", + envPtr->currStackDepth, initStackDepth+1); + } return TCL_OK; } @@ -829,8 +574,8 @@ TclCompileConcatCmd( * Procedure called to compile the "continue" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 "continue" command at @@ -848,9 +593,6 @@ TclCompileContinueCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - ExceptionRange *rangePtr; - ExceptionAux *auxPtr; - /* * There should be no argument after the "continue". */ @@ -860,27 +602,10 @@ TclCompileContinueCmd( } /* - * See if we can find a valid continueOffset (i.e., not -1) in the - * innermost containing exception range. + * Emit a continue instruction. */ - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - /* - * Found the target! No need for a nasty INST_CONTINUE here. - */ - - TclCleanupStackForBreakContinue(envPtr, auxPtr); - TclAddLoopContinueFixup(envPtr, auxPtr); - } else { - /* - * Emit a real continue. - */ - - TclEmitOpcode(INST_CONTINUE, envPtr); - } - TclAdjustStackDepth(1, envPtr); - + TclEmitOpcode(INST_CONTINUE, envPtr); return TCL_OK; } @@ -892,13 +617,32 @@ TclCompileContinueCmd( * Functions called to compile "dict" sucommands. * * Results: - * All return TCL_OK for a successful compile, and TCL_ERROR to defer - * evaluation to runtime. + * All return TCL_OK for a successful compile, and TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "dict" subcommand at * runtime. * + * Notes: + * The following commands are in fairly common use and are possibly worth + * bytecoding: + * dict append + * dict create [*] + * dict exists [*] + * dict for + * dict get [*] + * dict incr + * dict keys [*] + * dict lappend + * dict set + * dict unset + * + * In practice, those that are pure-value operators (marked with [*]) can + * probably be left alone (except perhaps [dict get] which is very very + * common) and [dict update] should be considered instead (really big + * win!) + * *---------------------------------------------------------------------- */ @@ -911,13 +655,12 @@ TclCompileDictSetCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; + Tcl_Token *tokenPtr, *varTokenPtr; int i, dictVarIndex; DefineLineInformation; /* TIP #280 */ - Tcl_Token *varTokenPtr; /* - * There must be at least one argument after the command. + * There must be at least three arguments after the (sub-)command. */ if (parsePtr->numWords < 4) { @@ -952,7 +695,6 @@ TclCompileDictSetCmd( TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -965,9 +707,9 @@ TclCompileDictIncrCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr; int dictVarIndex, incrAmount; + DefineLineInformation; /* TIP #280 */ /* * There must be at least two arguments after the command. @@ -976,7 +718,19 @@ TclCompileDictIncrCmd( if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } + + /* + * The dictionary variable must be a local scalar that is knowable at + * compile time; anything else exceeds the complexity of the opcode. So + * discover what the index is. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); + if (dictVarIndex < 0) { + return TCL_ERROR; + } + keyTokenPtr = TokenAfter(varTokenPtr); /* @@ -984,41 +738,19 @@ TclCompileDictIncrCmd( */ if (parsePtr->numWords == 4) { - const char *word; - int numBytes, code; - Tcl_Token *incrTokenPtr; - Tcl_Obj *intObj; - - incrTokenPtr = TokenAfter(keyTokenPtr); - if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); - } - word = incrTokenPtr[1].start; - numBytes = incrTokenPtr[1].size; - - intObj = Tcl_NewStringObj(word, numBytes); - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &incrAmount); - TclDecrRefCount(intObj); - if (code != TCL_OK) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); + Tcl_Token *incrTokenPtr = TokenAfter(keyTokenPtr); + Tcl_Obj *intObj = Tcl_NewObj(); + int fail = (!TclWordKnownAtCompileTime(incrTokenPtr, intObj) + || TCL_ERROR == TclGetIntFromObj(NULL, intObj, &incrAmount)); + Tcl_DecrRefCount(intObj); + if (fail) { + return TCL_ERROR; } } else { incrAmount = 1; } /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); - if (dictVarIndex < 0) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - /* * Emit the key and the code to actually do the increment. */ @@ -1046,7 +778,6 @@ TclCompileDictGetCmd( * case is legal, but too special and magic for us to deal with here). */ - /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1061,304 +792,6 @@ TclCompileDictGetCmd( tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; -} - -int -TclCompileDictExistsCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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 i; - DefineLineInformation; /* TIP #280 */ - - /* - * There must be at least two arguments after the command (the single-arg - * case is legal, but too special and magic for us to deal with here). - */ - - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Now we do the code generation. - */ - - for (i=1 ; i<parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; -} - -int -TclCompileDictUnsetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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; - DefineLineInformation; /* TIP #280 */ - int i, dictVarIndex; - - /* - * There must be at least one argument after the variable name for us to - * compile to bytecode. - */ - - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); - if (dictVarIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - /* - * Remaining words (the key path) can be handled normally. - */ - - for (i=2 ; i<parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - - /* - * Now emit the instruction to do the dict manipulation. - */ - - TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); - TclEmitInt4( dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictCreateCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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 */ - int worker; /* Temp var for building the value in. */ - Tcl_Token *tokenPtr; - Tcl_Obj *keyObj, *valueObj, *dictObj; - const char *bytes; - int i, len; - - if ((parsePtr->numWords & 1) == 0) { - return TCL_ERROR; - } - - /* - * See if we can build the value at compile time... - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - dictObj = Tcl_NewObj(); - Tcl_IncrRefCount(dictObj); - for (i=1 ; i<parsePtr->numWords ; i+=2) { - keyObj = Tcl_NewObj(); - Tcl_IncrRefCount(keyObj); - if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(dictObj); - goto nonConstant; - } - tokenPtr = TokenAfter(tokenPtr); - valueObj = Tcl_NewObj(); - Tcl_IncrRefCount(valueObj); - if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); - Tcl_DecrRefCount(dictObj); - goto nonConstant; - } - tokenPtr = TokenAfter(tokenPtr); - Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj); - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); - } - - /* - * We did! Excellent. The "verifyDict" is to do type forcing. - */ - - bytes = TclGetStringFromObj(dictObj, &len); - PushLiteral(envPtr, bytes, len); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Tcl_DecrRefCount(dictObj); - return TCL_OK; - - /* - * Otherwise, we've got to issue runtime code to do the building, which we - * do by [dict set]ting into an unnamed local variable. This requires that - * we are in a context with an LVT. - */ - - nonConstant: - worker = AnonymousLocal(envPtr); - if (worker < 0) { - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, worker, envPtr); - TclEmitOpcode( INST_POP, envPtr); - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<parsePtr->numWords ; i+=2) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i+1); - tokenPtr = TokenAfter(tokenPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( worker, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( worker, envPtr); - return TCL_OK; -} - -int -TclCompileDictMergeCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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, workerIndex, infoIndex, outLoop; - - /* - * Deal with some special edge cases. Note that in the case with one - * argument, the only thing to do is to verify the dict-ness. - */ - - /* TODO: Consider support for compiling expanded args. (less likely) */ - if (parsePtr->numWords < 2) { - PushStringLiteral(envPtr, ""); - return TCL_OK; - } else if (parsePtr->numWords == 2) { - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - return TCL_OK; - } - - /* - * There's real merging work to do. - * - * Allocate some working space. This means we'll only ever compile this - * command when there's an LVT present. - */ - - workerIndex = AnonymousLocal(envPtr); - if (workerIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - infoIndex = AnonymousLocal(envPtr); - - /* - * Get the first dictionary and verify that it is so. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * For each of the remaining dictionaries... - */ - - outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); - ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; i<parsePtr->numWords ; i++) { - /* - * Get the dictionary, and merge its pairs into the first dict (using - * a small loop). - */ - - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - } - ExceptionRangeEnds(envPtr, outLoop); - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Clean up any state left over. - */ - - Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_JUMP1, 18, envPtr); - - /* - * If an exception happens when starting to iterate over the second (and - * subsequent) dicts. This is strictly not necessary, but it is nice. - */ - - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, outLoop, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); - return TCL_OK; } @@ -1371,71 +804,32 @@ TclCompileDictForCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_KEEP_NONE); -} - -int -TclCompileDictMapCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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. */ -{ - return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -int -CompileDictEachCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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 collect) /* Flag == TCL_EACH_COLLECT to collect and - * construct a new dictionary with the loop - * body result. */ -{ - DefineLineInformation; /* TIP #280 */ + Proc *procPtr = envPtr->procPtr; Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; + int keyVarIndex, valueVarIndex, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - int numVars, endTargetOffset; - int collectVar = -1; /* Index of temp var holding the result - * dict. */ - const char **argv; - Tcl_DString buffer; + int numVars, endTargetOffset, numBytes; + const char *bytes; + int savedStackDepth = envPtr->currStackDepth; + /* Needed because jumps confuse the stack + * space calculator. */ + Tcl_Obj *varNameObj, *varListObj = NULL; + DefineLineInformation; /* TIP #280 */ /* - * There must be three arguments after the command. + * There must be exactly three arguments after the command. */ - if (parsePtr->numWords != 4) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + if (parsePtr->numWords != 4 || procPtr == NULL) { + return TCL_ERROR; } varsTokenPtr = TokenAfter(parsePtr->tokenPtr); dictTokenPtr = TokenAfter(varsTokenPtr); bodyTokenPtr = TokenAfter(dictTokenPtr); - if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || - bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - /* - * Create temporary variable to capture return values from loop body when - * we're collecting results. - */ - - if (collect == TCL_EACH_COLLECT) { - collectVar = AnonymousLocal(envPtr); - if (collectVar < 0) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } + if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; } /* @@ -1443,29 +837,32 @@ CompileDictEachCmd( * Then extract their indices in the LVT. */ - Tcl_DStringInit(&buffer); - TclDStringAppendToken(&buffer, &varsTokenPtr[1]); - if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars, - &argv) != TCL_OK) { - Tcl_DStringFree(&buffer); - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - Tcl_DStringFree(&buffer); - if (numVars != 2) { - ckfree(argv); - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + varListObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(varsTokenPtr, varListObj) || + TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || + numVars != 2) { + Tcl_DecrRefCount(varListObj); + return TCL_ERROR; } - nameChars = strlen(argv[0]); - keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); - nameChars = strlen(argv[1]); - valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); - ckfree(argv); + Tcl_ListObjIndex(NULL, varListObj, 0, &varNameObj); + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + keyVarIndex = LocalScalar(bytes, numBytes, envPtr); + if (keyVarIndex < 0) { + Tcl_DecrRefCount(varListObj); + return TCL_ERROR; + } - if ((keyVarIndex < 0) || (valueVarIndex < 0)) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + Tcl_ListObjIndex(NULL, varListObj, 1, &varNameObj); + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + valueVarIndex = LocalScalar(bytes, numBytes, envPtr); + if (valueVarIndex < 0) { + Tcl_DecrRefCount(varListObj); + return TCL_ERROR; } + Tcl_DecrRefCount(varListObj); + /* * Allocate a temporary variable to store the iterator reference. The * variable will contain a Tcl_DictSearch reference which will be @@ -1473,75 +870,54 @@ CompileDictEachCmd( * (at which point it should also have been finished with). */ - infoIndex = AnonymousLocal(envPtr); - if (infoIndex < 0) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } + infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr); /* * Preparation complete; issue instructions. Note that this code issues * fixed-sized jumps. That simplifies things a lot! * - * First up, initialize the accumulator dictionary if needed. - */ - - if (collect == TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* - * Get the dictionary and start the iteration. No catching of errors at - * this point. + * First up, get the dictionary and start the iteration. No catching of + * errors at this point. */ CompileWord(envPtr, dictTokenPtr, interp, 2); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + emptyTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); - /* * Inside the iteration, write the loop variables. */ bodyTargetOffset = CurrentOffset(envPtr); - Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Set up the loop exception targets. */ - loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); ExceptionRangeStarts(envPtr, loopRange); /* * Compile the loop body itself. It should be stack-neutral. */ - BODY(bodyTokenPtr, 3); - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_DICT_SET, 1, envPtr); - TclEmitInt4( collectVar, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - TclEmitOpcode( INST_POP, envPtr); + SetLineInformation(3); + CompileBody(envPtr, bodyTokenPtr, interp); + TclEmitOpcode( INST_POP, envPtr); /* * Both exception target ranges (error and loop) end here. @@ -1557,29 +933,37 @@ CompileDictEachCmd( */ ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * Now do the final cleanup for the no-error case (this is where we break + * out of the loop to) by force-terminating the iteration (if not already + * terminated), ditching the exception info and jumping to the last + * instruction for this command. In theory, this could be done using the + * "finally" clause (next generated) but this is faster. + */ + + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP1, 0, envPtr); + TclEmitInstInt4( INST_JUMP4, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the iteration * and rethrows the error. */ - TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); /* * Otherwise we're done (the jump after the DICT_FIRST points here) and we @@ -1587,33 +971,24 @@ CompileDictEachCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ + envPtr->currStackDepth = savedStackDepth+2; jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, - envPtr->codeStart + endTargetOffset); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); /* * Final stage of the command (normal case) is that we push an empty - * object (or push the accumulator as the result object). This is done - * last to promote peephole optimization when it's dropped immediately. + * object. This is done last to promote peephole optimization when it's + * dropped immediately. */ - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } + jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, + envPtr->codeStart + endTargetOffset); + PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -1626,19 +1001,11 @@ TclCompileDictUpdateCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ int i, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; JumpFixup jumpFixup; - - /* - * There must be at least one argument after the command. - */ - - if (parsePtr->numWords < 5) { - return TCL_ERROR; - } + DefineLineInformation; /* TIP #280 */ /* * Parse the command. Expect the following: @@ -1649,6 +1016,9 @@ TclCompileDictUpdateCmd( return TCL_ERROR; } numVars = (parsePtr->numWords - 3) / 2; + if (numVars < 1) { + return TCL_ERROR; + } /* * The dictionary variable must be a local scalar that is knowable at @@ -1659,7 +1029,7 @@ TclCompileDictUpdateCmd( dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr); if (dictIndex < 0) { - goto issueFallback; + return TCL_ERROR; } /* @@ -1668,32 +1038,45 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); + duiPtr = (DictUpdateInfo *) + ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); duiPtr->length = numVars; - keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); + keyTokenPtrs = (Tcl_Token **) TclStackAlloc(interp, + sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; i<numVars ; i++) { + int index; + /* * Put keys to one side for later compilation to bytecode. */ keyTokenPtrs[i] = tokenPtr; - tokenPtr = TokenAfter(tokenPtr); /* - * Stash the index in the auxiliary data (if it is indeed a local - * scalar that is resolvable at compile-time). + * Variables first need to be checked for sanity. */ - duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); - if (duiPtr->varIndices[i] < 0) { - goto failedUpdateInfoAssembly; + tokenPtr = TokenAfter(tokenPtr); + index = LocalScalarFromToken(tokenPtr, envPtr); + if (index < 0) { + ckfree((char *) duiPtr); + TclStackFree(interp, keyTokenPtrs); + return TCL_ERROR; } + + /* + * Stash the index in the auxiliary data. + */ + + duiPtr->varIndices[i] = index; tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedUpdateInfoAssembly; + ckfree((char *) duiPtr); + TclStackFree(interp, keyTokenPtrs); + return TCL_ERROR; } bodyTokenPtr = tokenPtr; @@ -1702,20 +1085,21 @@ TclCompileDictUpdateCmd( * can't be snagged by literal sharing and forced to shimmer dangerously. */ - infoIndex = TclCreateAuxData(duiPtr, &dictUpdateInfoType, envPtr); + infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2); } - TclEmitInstInt4( INST_LIST, numVars, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInstInt4( INST_LIST, numVars, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - BODY(bodyTokenPtr, parsePtr->numWords - 1); + SetLineInformation(parsePtr->numWords - 1); + CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); /* @@ -1723,10 +1107,10 @@ TclCompileDictUpdateCmd( * the body evaluation: swap them and finish the update code. */ - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Jump around the exceptional termination code. @@ -1741,14 +1125,14 @@ TclCompileDictUpdateCmd( */ ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitInvoke(envPtr,INST_RETURN_STK); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", @@ -1756,16 +1140,6 @@ TclCompileDictUpdateCmd( } TclStackFree(interp, keyTokenPtrs); return TCL_OK; - - /* - * Clean up after a failure to create the DictUpdateInfo structure. - */ - - failedUpdateInfoAssembly: - ckfree(duiPtr); - TclStackFree(interp, keyTokenPtrs); - issueFallback: - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int @@ -1777,18 +1151,17 @@ TclCompileDictAppendCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i, dictVarIndex; + DefineLineInformation; /* TIP #280 */ /* - * There must be at least two argument after the command. And we impose an - * (arbirary) safe limit; anyone exceeding it should stop worrying about - * speed quite so much. ;-) + * There must be at least two argument after the command. Since we + * implement using INST_CONCAT1, make sure the number of arguments + * stays within its range. */ - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords<4 || parsePtr->numWords>100) { + if (parsePtr->numWords<4 || parsePtr->numWords>258) { return TCL_ERROR; } @@ -1799,7 +1172,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); if (dictVarIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); + return TCL_ERROR; } /* @@ -1812,7 +1185,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); } if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); + TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -1832,290 +1205,28 @@ TclCompileDictLappendCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; int dictVarIndex; + DefineLineInformation; /* TIP #280 */ /* * There must be three arguments after the command. */ - /* TODO: Consider support for compiling expanded args. */ - /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ if (parsePtr->numWords != 4) { return TCL_ERROR; } - /* - * Parse the arguments. - */ - varTokenPtr = TokenAfter(parsePtr->tokenPtr); keyTokenPtr = TokenAfter(varTokenPtr); valueTokenPtr = TokenAfter(keyTokenPtr); dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + return TCL_ERROR; } - - /* - * Issue the implementation. - */ - CompileWord(envPtr, keyTokenPtr, interp, 2); CompileWord(envPtr, valueTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictWithCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - 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 */ - int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; - int dictVar, bodyIsEmpty = 1; - Tcl_Token *varTokenPtr, *tokenPtr; - JumpFixup jumpFixup; - const char *ptr, *end; - - /* - * There must be at least one argument after the command. - */ - - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - /* - * Parse the command (trivially). Expect the following: - * dict with <any (varName)> ?<any> ...? <literal> - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; i<parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - /* - * Test if the last word is an empty script; if so, we can compile it in - * all cases, but if it is non-empty we need local variable table entries - * to hold the temporary variables (used to keep stack usage simple). - */ - - for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) { - if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') { - if (envPtr->procPtr == NULL) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, - envPtr); - } - bodyIsEmpty = 0; - break; - } - } - - /* - * Determine if we're manipulating a dict in a simple local variable. - */ - - gotPath = (parsePtr->numWords > 3); - dictVar = LocalScalarFromToken(varTokenPtr, envPtr); - - /* - * Special case: an empty body means we definitely have no need to issue - * try-finally style code or to allocate local variable table entries for - * storing temporaries. Still need to do both INST_DICT_EXPAND and - * INST_DICT_RECOMBINE_* though, because we can't determine if we're free - * of traces. - */ - - if (bodyIsEmpty) { - if (dictVar >= 0) { - if (gotPath) { - /* - * Case: Path into dict in LVT with empty body. - */ - - tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } else { - /* - * Case: Direct dict in LVT with empty body. - */ - - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - } else { - if (gotPath) { - /* - * Case: Path into dict in non-simple var with empty body. - */ - - tokenPtr = varTokenPtr; - for (i=1 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - /* - * Case: Direct dict in non-simple var with empty body. - */ - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } - } - PushStringLiteral(envPtr, ""); - return TCL_OK; - } - - /* - * OK, we have a non-trivial body. This means that the focus is on - * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes - * in the 'finally' clause. - * - * Start by allocating local (unnamed, untraced) working variables. - */ - - if (dictVar == -1) { - varNameTmp = AnonymousLocal(envPtr); - } - if (gotPath) { - pathTmp = AnonymousLocal(envPtr); - } - keysTmp = AnonymousLocal(envPtr); - - /* - * Issue instructions. First, the part to expand the dictionary. - */ - - if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 1); - Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); - } - tokenPtr = TokenAfter(varTokenPtr); - if (gotPath) { - for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); - Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - if (dictVar == -1) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Now the body of the [dict with]. - */ - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - - ExceptionRangeStarts(envPtr, range); - BODY(tokenPtr, parsePtr->numWords - 1); - ExceptionRangeEnds(envPtr, range); - - /* - * Now fold the results back into the dictionary in the OK case. - */ - - TclEmitOpcode( INST_END_CATCH, envPtr); - if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - /* - * Now fold the results back into the dictionary in the exception case. - */ - - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if (parsePtr->numWords > 3) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - TclEmitInvoke(envPtr, INST_RETURN_STK); - - /* - * Prepare for the start of the next command. - */ - - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } + TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } @@ -2131,13 +1242,11 @@ TclCompileDictWithCmd( * DupDictUpdateInfo: a copy of the auxiliary data * FreeDictUpdateInfo: none * PrintDictUpdateInfo: none - * DisassembleDictUpdateInfo: none * * Side effects: * DupDictUpdateInfo: allocates memory * FreeDictUpdateInfo: releases memory * PrintDictUpdateInfo: none - * DisassembleDictUpdateInfo: none * *---------------------------------------------------------------------- */ @@ -2151,7 +1260,7 @@ DupDictUpdateInfo( dui1Ptr = clientData; len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1); - dui2Ptr = ckalloc(len); + dui2Ptr = (DictUpdateInfo *) ckalloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; } @@ -2180,99 +1289,6 @@ PrintDictUpdateInfo( Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); } } - -static void -DisassembleDictUpdateInfo( - ClientData clientData, - Tcl_Obj *dictObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - DictUpdateInfo *duiPtr = clientData; - int i; - Tcl_Obj *variables = Tcl_NewObj(); - - for (i=0 ; i<duiPtr->length ; i++) { - Tcl_ListObjAppendElement(NULL, variables, - Tcl_NewIntObj(duiPtr->varIndices[i])); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), - variables); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileErrorCmd -- - * - * Procedure called to compile the "error" 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 "error" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileErrorCmd( - Tcl_Interp *interp, /* Used for context. */ - 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. */ -{ - /* - * General syntax: [error message ?errorInfo? ?errorCode?] - */ - - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - - /* - * Handle the message. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Construct the options. Note that -code and -level are not here. - */ - - if (parsePtr->numWords == 2) { - PushStringLiteral(envPtr, ""); - } else { - PushStringLiteral(envPtr, "-errorinfo"); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - if (parsePtr->numWords == 3) { - TclEmitInstInt4( INST_LIST, 2, envPtr); - } else { - PushStringLiteral(envPtr, "-errorcode"); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); - TclEmitInstInt4( INST_LIST, 4, envPtr); - } - } - - /* - * Issue the error via 'returnImm error 0'. - */ - - TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); - return TCL_OK; -} /* *---------------------------------------------------------------------- @@ -2282,8 +1298,8 @@ TclCompileErrorCmd( * Procedure called to compile the "expr" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 "expr" command at @@ -2327,8 +1343,8 @@ TclCompileExprCmd( * Procedure called to compile the "for" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 "for" command at @@ -2348,8 +1364,9 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int bodyCodeOffset, nextCodeOffset, jumpDist; + int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; + int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 5) { @@ -2381,10 +1398,20 @@ TclCompileForCmd( } /* + * Create ExceptionRange records for the body and the "next" command. The + * "next" command's ExceptionRange supports break but not continue (and + * has a -1 continueOffset). + */ + + bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + + /* * Inline compile the initial command. */ - BODY(startTokenPtr, 1); + SetLineInformation (1); + CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); /* @@ -2405,37 +1432,44 @@ TclCompileForCmd( * Compile the loop body. */ - bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - BODY(bodyTokenPtr, 4); + SetLineInformation (4); + CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); + envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* - * Compile the "next" subcommand. Note that this exception range will not - * have a continueOffset (other than -1) connected to it; it won't trap - * TCL_CONTINUE but rather just TCL_BREAK. + * Compile the "next" subcommand. */ - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; + envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - BODY(nextTokenPtr, 3); + SetLineInformation (3); + CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); + envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); + envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that * terminates the for. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { + testCodeOffset = CurrentOffset(envPtr); + + jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; + testCodeOffset += 3; } - SetLineInformation(2); + SetLineInformation (2); + envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { @@ -2456,14 +1490,13 @@ TclCompileForCmd( ExceptionRangeTarget(envPtr, bodyRange, breakOffset); ExceptionRangeTarget(envPtr, nextRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, bodyRange); - TclFinalizeLoopExceptionRange(envPtr, nextRange); /* * The for command's result is an empty string. */ - PushStringLiteral(envPtr, ""); + envPtr->currStackDepth = savedStackDepth; + PushLiteral(envPtr, "", 0); return TCL_OK; } @@ -2476,8 +1509,8 @@ TclCompileForCmd( * Procedure called to compile the "foreach" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 "foreach" command at @@ -2495,78 +1528,16 @@ TclCompileForeachCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_KEEP_NONE); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLmapCmd -- - * - * Procedure called to compile the "lmap" 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 "lmap" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLmapCmd( - 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. */ -{ - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -/* - *---------------------------------------------------------------------- - * - * CompileEachloopCmd -- - * - * Procedure called to compile the "foreach" and "lmap" 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 "foreach" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileEachloopCmd( - 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 collect) /* Select collecting or accumulating mode - * (TCL_EACH_*) */ -{ Proc *procPtr = envPtr->procPtr; - ForeachInfo *infoPtr=NULL; /* Points to the structure describing this + ForeachInfo *infoPtr = NULL;/* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - Tcl_Token *tokenPtr, *bodyTokenPtr; - int jumpBackOffset, infoIndex, range; - int numWords, numLists, i, j, code = TCL_OK; + unsigned char *jumpPc; + JumpFixup jumpFalseFixup; + int jumpBackDist, jumpBackOffset, infoIndex, range; + int numWords, numLists, tempVar, i, j, code = TCL_OK; + int savedStackDepth = envPtr->currStackDepth; Tcl_Obj *varListObj = NULL; DefineLineInformation; /* TIP #280 */ @@ -2604,12 +1575,12 @@ CompileEachloopCmd( */ numLists = (numWords - 2)/2; - infoPtr = ckalloc(sizeof(ForeachInfo) - + (numLists - 1) * sizeof(ForeachVarList *)); + infoPtr = (ForeachInfo *) ckalloc((unsigned) + sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); infoPtr->numLists = 0; /* Count this up as we go */ /* - * Parse each var list into sequence of var names. Don't + * Parse each var list into sequence of var names. Don't * compile the foreach inline if any var name needs substitutions or isn't * a scalar, or if any var list needs substitutions. */ @@ -2627,8 +1598,8 @@ CompileEachloopCmd( /* * If the variable list is empty, we can enter an infinite loop when - * the interpreted version would not. Take care to ensure this does - * not happen. [Bug 1671138] + * the interpreted version would not. Take care to ensure this does + * not happen. [Bug 1671138] */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || @@ -2638,108 +1609,162 @@ CompileEachloopCmd( goto done; } - varListPtr = ckalloc(sizeof(ForeachVarList) - + (numVars - 1) * sizeof(int)); + varListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; for (j = 0; j < numVars; j++) { Tcl_Obj *varNameObj; + int numBytes; const char *bytes; - int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = TclGetStringFromObj(varNameObj, &numBytes); - varIndex = LocalScalar(bytes, numBytes, envPtr); - if (varIndex < 0) { + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + varListPtr->varIndexes[j] = LocalScalar(bytes, numBytes, envPtr); + if (varListPtr->varIndexes[j] < 0) { code = TCL_ERROR; goto done; } - varListPtr->varIndexes[j] = varIndex; } Tcl_SetObjLength(varListObj, 0); } /* - * We will compile the foreach command. + * Reserve (numLists + 1) temporary variables: + * - numLists temps to hold each value list + * - 1 temp for the loop counter (index of next element in each list) + * + * At this time we don't try to reuse temporaries; if there are two + * nonoverlapping foreach loops, they don't share any temps. */ - infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); + tempVar = TclFindCompiledLocal(NULL, 0, 1, procPtr); + infoPtr->firstValueTemp = tempVar; + for (i= 1; i < numLists; i++) { + TclFindCompiledLocal(NULL, 0, 1, procPtr); + } + infoPtr->loopCtTemp = TclFindCompiledLocal(NULL, 0, 1, procPtr); + + infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); /* - * Create the collecting object, unshared. + * Create an exception record to handle [break] and [continue]. */ - if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt4(INST_LIST, 0, envPtr); - } + range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); /* - * Evaluate each value list and leave it on stack. + * Evaluate then store each value list in the associated temporary. */ for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - CompileWord(envPtr, tokenPtr, interp, i); + SetLineInformation (i); + CompileTokens(envPtr, tokenPtr, interp); + if (tempVar <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + tempVar++; } } - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + /* + * Initialize the temporary var that holds the count of loop iterations. + */ + + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); /* - * Inline compile the loop body. + * Top of loop code: assign each loop variable and check whether + * to terminate the loop. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeTarget(envPtr, range, continueOffset); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + /* + * Inline compile the loop body. + */ + + SetLineInformation (numWords - 1); ExceptionRangeStarts(envPtr, range); - BODY(bodyTokenPtr, numWords - 1); + CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); + envPtr->currStackDepth = savedStackDepth + 1; + TclEmitOpcode(INST_POP, envPtr); - if (collect == TCL_EACH_COLLECT) { - TclEmitOpcode(INST_LMAP_COLLECT, envPtr); + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump if + * the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = CurrentOffset(envPtr); + jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); } else { - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); } /* - * Bottom of loop code: assign each loop variable and check whether - * to terminate the loop. Set the loop's break target. + * Fix the target of the jump after the foreach_step test. */ - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitOpcode(INST_FOREACH_STEP, envPtr); - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); - TclEmitOpcode(INST_FOREACH_END, envPtr); - TclAdjustStackDepth(-(numLists+2), envPtr); + if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } /* - * Set the jumpback distance from INST_FOREACH_STEP to the start of the - * body's code. Misuse loopCtTemp for storing the jump size. + * Set the loop's break target. */ - jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - - envPtr->exceptArrayPtr[range].codeOffset; - infoPtr->loopCtTemp = -jumpBackOffset; + ExceptionRangeTarget(envPtr, range, breakOffset); /* - * The command's result is an empty string if not collecting. If - * collecting, it is automatically left on stack after FOREACH_END. + * The foreach command's result is an empty string. */ - if (collect != TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - } + envPtr->currStackDepth = savedStackDepth; + PushLiteral(envPtr, "", 0); + envPtr->currStackDepth = savedStackDepth + 1; - done: + done: if (code == TCL_ERROR) { - FreeForeachInfo(infoPtr); + if (infoPtr) { + FreeForeachInfo(infoPtr); + } + } + if (varListObj) { + Tcl_DecrRefCount(varListObj); } - Tcl_DecrRefCount(varListObj); return code; } @@ -2774,8 +1799,8 @@ DupForeachInfo( register ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = ckalloc(sizeof(ForeachInfo) - + numLists * sizeof(ForeachVarList *)); + dupPtr = (ForeachInfo *) ckalloc((unsigned) + sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; @@ -2783,8 +1808,8 @@ DupForeachInfo( for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = ckalloc(sizeof(ForeachVarList) - + numVars * sizeof(int)); + dupListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; @@ -2825,18 +1850,18 @@ FreeForeachInfo( for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; - ckfree(listPtr); + ckfree((char *) listPtr); } - ckfree(infoPtr); + ckfree((char *) infoPtr); } /* *---------------------------------------------------------------------- * - * PrintForeachInfo, DisassembleForeachInfo -- + * PrintForeachInfo -- * - * Functions to write a human-readable or script-readablerepresentation - * of a ForeachInfo structure to a Tcl_Obj for debugging. + * Function to write a human-readable representation of a ForeachInfo + * structure to stdout for debugging. * * Results: * None. @@ -2886,141 +1911,685 @@ PrintForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * Procedure called to compile the "if" 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 "if" command at + * runtime. + * + *---------------------------------------------------------------------- + */ -static void -PrintNewForeachInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) +int +TclCompileIfCmd( + 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. */ { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; - int i, j; + JumpFixupArray jumpFalseFixupArray; + /* Used to fix the ifFalse jump after each + * test when its target PC is determined. */ + JumpFixupArray jumpEndFixupArray; + /* Used to fix the jump after each "then" body + * to the end of the "if" when that PC is + * determined. */ + Tcl_Token *tokenPtr, *testTokenPtr; + int jumpIndex = 0; /* Avoid compiler warning. */ + int jumpFalseDist, numWords, wordIdx, numBytes, j, code; + const char *word; + int savedStackDepth = envPtr->currStackDepth; + /* Saved stack depth at the start of the first + * test; the envPtr current depth is restored + * to this value at the start of each test. */ + int realCond = 1; /* Set to 0 for static conditions: + * "if 0 {..}" */ + int boolVal; /* Value of static condition. */ + int compileScripts = 1; + DefineLineInformation; /* TIP #280 */ - Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", - infoPtr->loopCtTemp); - for (i=0 ; i<infoPtr->numLists ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ",", -1); + /* + * Only compile the "if" command if all arguments are simple words, in + * order to insure correct substitution [Bug 219166] + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + + for (wordIdx = 0; wordIdx < numWords; wordIdx++) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; } - Tcl_AppendToObj(appendObj, "[", -1); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; j<varsPtr->numVars ; j++) { - if (j) { - Tcl_AppendToObj(appendObj, ",", -1); + tokenPtr = TokenAfter(tokenPtr); + } + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + code = TCL_OK; + + /* + * Each iteration of this loop compiles one "if expr ?then? body" or + * "elseif expr ?then? body" clause. + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + while (wordIdx < numWords) { + /* + * Stop looping if the token isn't "if" or "elseif". + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((tokenPtr == parsePtr->tokenPtr) + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + } else { + break; + } + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + + /* + * Compile the test expression then emit the conditional jump around + * the "then" part. + */ + + envPtr->currStackDepth = savedStackDepth; + testTokenPtr = tokenPtr; + + if (realCond) { + /* + * Find out if the condition is a constant. + */ + + Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, + testTokenPtr[1].size); + Tcl_IncrRefCount(boolObj); + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); + TclDecrRefCount(boolObj); + if (code == TCL_OK) { + /* + * A static condition. + */ + + realCond = 0; + if (!boolVal) { + compileScripts = 0; + } + } else { + SetLineInformation (wordIdx); + Tcl_ResetResult(interp); + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + jumpFalseFixupArray.fixup+jumpIndex); } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); + code = TCL_OK; } - Tcl_AppendToObj(appendObj, "]", -1); + + /* + * Skip over the optional "then" before the then clause. + */ + + tokenPtr = TokenAfter(testTokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "then" command body. + */ + + if (compileScripts) { + SetLineInformation (wordIdx); + envPtr->currStackDepth = savedStackDepth; + CompileBody(envPtr, tokenPtr, interp); + } + + if (realCond) { + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray + * and jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + jumpEndFixupArray.fixup+jumpIndex); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 + * byte jump if the distance is > 120 bytes. This is conservative, + * and ensures that we won't have to replace this jump if we later + * also need to replace the proceeding jump to the end of the "if" + * with a 4 byte jump. + */ + + if (TclFixupForwardJumpToHere(envPtr, + jumpFalseFixupArray.fixup+jumpIndex, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + } else if (boolVal) { + /* + * We were processing an "if 1 {...}"; stop compiling scripts. + */ + + compileScripts = 0; + } else { + /* + * We were processing an "if 0 {...}"; reset so that the rest + * (elseif, else) is compiled correctly. + */ + + realCond = 1; + compileScripts = 1; + } + + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; } + + /* + * Restore the current stack depth in the environment; the "else" clause + * (or its default) will add 1 to this. + */ + + envPtr->currStackDepth = savedStackDepth; + + /* + * Check for the optional else clause. Do not compile anything if this was + * an "if 1 {...}" case. + */ + + if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * There is an else clause. Skip over the optional "else" word. + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + + if (compileScripts) { + /* + * Compile the else command body. + */ + + SetLineInformation (wordIdx); + CompileBody(envPtr, tokenPtr, interp); + } + + /* + * Make sure there are no words after the else clause. + */ + + wordIdx++; + if (wordIdx < numWords) { + code = TCL_ERROR; + goto done; + } + } else { + /* + * No else clause: the "if" command's result is an empty string. + */ + + if (compileScripts) { + PushLiteral(envPtr, "", 0); + } + } + + /* + * Fix the unconditional jumps to the end of the "if" command. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first. */ + if (TclFixupForwardJumpToHere(envPtr, + jumpEndFixupArray.fixup+jumpIndex, 127)) { + /* + * Adjust the immediately preceeding "ifFalse" jump. We moved it's + * target (just after this jump) down three bytes. + */ + + unsigned char *ifFalsePc = envPtr->codeStart + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + unsigned char opCode = *ifFalsePc; + + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + envPtr->currStackDepth = savedStackDepth + 1; + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + return code; } + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * Procedure called to compile the "incr" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "incr" command at + * runtime. + * + *---------------------------------------------------------------------- + */ -static void -DisassembleForeachInfo( - ClientData clientData, - Tcl_Obj *dictObj, - ByteCode *codePtr, - unsigned int pcOffset) +int +TclCompileIncrCmd( + 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. */ { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; - int i, j; - Tcl_Obj *objPtr, *innerPtr; + Tcl_Token *varTokenPtr, *incrTokenPtr; + int simpleVarName, isScalar, localIndex, haveImmValue, immValue; + DefineLineInformation; /* TIP #280 */ + + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + return TCL_ERROR; + } + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); /* - * Data stores. + * If an increment is given, push it, but see first if it's a small + * integer. */ - objPtr = Tcl_NewObj(); - for (i=0 ; i<infoPtr->numLists ; i++) { - Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(infoPtr->firstValueTemp + i)); + haveImmValue = 0; + immValue = 1; + if (parsePtr->numWords == 3) { + incrTokenPtr = TokenAfter(varTokenPtr); + if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + const char *word = incrTokenPtr[1].start; + int numBytes = incrTokenPtr[1].size; + int code; + Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); + Tcl_IncrRefCount(intObj); + code = TclGetIntFromObj(NULL, intObj, &immValue); + TclDecrRefCount(intObj); + if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { + haveImmValue = 1; + } + if (!haveImmValue) { + PushLiteral(envPtr, word, numBytes); + } + } else { + SetLineInformation (2); + CompileTokens(envPtr, incrTokenPtr, interp); + } + } else { /* No incr amount given so use 1. */ + haveImmValue = 1; } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); /* - * Loop counter. + * Emit the instruction to increment the variable. */ - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); + } + } + } else { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); + } + } + } + } else { /* Non-simple variable name. */ + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_STK, envPtr); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLappendCmd -- + * + * Procedure called to compile the "lappend" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lappend" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLappendCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int simpleVarName, isScalar, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ /* - * Assignment targets. + * If we're not in a procedure, don't compile. */ - objPtr = Tcl_NewObj(); - for (i=0 ; i<infoPtr->numLists ; i++) { - innerPtr = Tcl_NewObj(); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; j<varsPtr->numVars ; j++) { - Tcl_ListObjAppendElement(NULL, innerPtr, - Tcl_NewIntObj(varsPtr->varIndexes[j])); + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords == 1) { + return TCL_ERROR; + } + if (numWords != 3) { + /* + * LAPPEND instructions currently only handle one value appends. + */ + + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * If we are doing an assignment, push the new value. In the no values + * case, create an empty object. + */ + + if (numWords > 2) { + Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); + } + + /* + * Emit instructions to set/get the variable. + */ + + /* + * The *_STK opcodes should be refactored to make better use of existing + * LOAD/STORE instructions. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); + } } - Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + } else { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); + + return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TclCompileLassignCmd -- + * + * Procedure called to compile the "lassign" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lassign" command at + * runtime. + * + *---------------------------------------------------------------------- + */ -static void -DisassembleNewForeachInfo( - ClientData clientData, - Tcl_Obj *dictObj, - ByteCode *codePtr, - unsigned int pcOffset) +int +TclCompileLassignCmd( + 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. */ { - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; - int i, j; - Tcl_Obj *objPtr, *innerPtr; + Tcl_Token *tokenPtr; + int simpleVarName, isScalar, localIndex, numWords, idx; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; /* - * Jump offset. + * Check for command syntax error, but we'll punt that to runtime. */ - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + if (numWords < 3) { + return TCL_ERROR; + } /* - * Assignment targets. + * Generate code to push list being taken apart by [lassign]. */ - objPtr = Tcl_NewObj(); - for (i=0 ; i<infoPtr->numLists ; i++) { - innerPtr = Tcl_NewObj(); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; j<varsPtr->numVars ; j++) { - Tcl_ListObjAppendElement(NULL, innerPtr, - Tcl_NewIntObj(varsPtr->varIndexes[j])); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Generate code to assign values from the list to variables. + */ + + for (idx=0 ; idx<numWords-2 ; idx++) { + tokenPtr = TokenAfter(tokenPtr); + + /* + * Generate the next variable name. + */ + + PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, + &simpleVarName, &isScalar, idx+2); + + /* + * Emit instructions to get the idx'th item out of the list value on + * the stack and assign it to the variable. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + TclEmitOpcode(INST_DUP, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr); + } + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); + } + } else { + if (localIndex >= 0) { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + } + } else { + TclEmitInstInt4(INST_OVER, 2, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); + } + } + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_STK, envPtr); } - Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + TclEmitOpcode(INST_POP, envPtr); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); + + /* + * Generate code to leave the rest of the list on the stack. + */ + + TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4(-2, envPtr); /* -2 == "end" */ + + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclCompileFormatCmd -- + * TclCompileLindexCmd -- * - * Procedure called to compile the "format" command. Handles cases that - * can be done as constants or simple string concatenation only. + * Procedure called to compile the "lindex" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 "format" command at + * Instructions are added to envPtr to execute the "lindex" command at * runtime. * *---------------------------------------------------------------------- */ int -TclCompileFormatCmd( +TclCompileLindexCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ @@ -3028,273 +2597,2190 @@ TclCompileFormatCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + Tcl_Token *idxTokenPtr, *valTokenPtr; + int i, numWords = parsePtr->numWords; DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - Tcl_Obj **objv, *formatObj, *tmpObj; - char *bytes, *start; - int i, j, len; /* - * Don't handle any guaranteed-error cases. + * Quit if too few args. */ - if (parsePtr->numWords < 2) { + if (numWords <= 1) { return TCL_ERROR; } + valTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (numWords != 3) { + goto emitComplexLindex; + } + + idxTokenPtr = TokenAfter(valTokenPtr); + if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + Tcl_Obj *tmpObj; + int idx, result; + + tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx); + TclDecrRefCount(tmpObj); + + if (result == TCL_OK && idx >= 0) { + /* + * All checks have been completed, and we have exactly this + * construct: + * lindex <arbitraryValue> <posInt> + * This is best compiled as a push of the arbitrary value followed + * by an "immediate lindex" which is the most efficient variety. + */ + + CompileWord(envPtr, valTokenPtr, interp, 1); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + return TCL_OK; + } + + /* + * If the conversion failed or the value was negative, we just keep on + * going with the more complex compilation. + */ + } + /* - * Check if the argument words are all compile-time-known literals; that's - * a case we can handle by compiling to a constant. + * Push the operands onto the stack. */ - formatObj = Tcl_NewObj(); - Tcl_IncrRefCount(formatObj); - tokenPtr = TokenAfter(tokenPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { - Tcl_DecrRefCount(formatObj); + emitComplexLindex: + for (i=1 ; i<numWords ; i++) { + CompileWord(envPtr, valTokenPtr, interp, i); + valTokenPtr = TokenAfter(valTokenPtr); + } + + /* + * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are + * multiple index args. + */ + + if (numWords == 3) { + TclEmitOpcode(INST_LIST_INDEX, envPtr); + } else { + TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileListCmd -- + * + * Procedure called to compile the "list" 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 "list" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileListCmd( + 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 */ + + /* + * If we're not in a procedure, don't compile. + */ + + if (envPtr->procPtr == NULL) { return TCL_ERROR; } - objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); - for (i=0 ; i+2 < parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - objv[i] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[i]); - if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { - goto checkForStringConcatCase; + if (parsePtr->numWords == 1) { + /* + * [list] without arguments just pushes an empty object. + */ + + PushLiteral(envPtr, "", 0); + } else { + /* + * Push the all values onto the stack. + */ + + Tcl_Token *valueTokenPtr; + int i, numWords; + + numWords = parsePtr->numWords; + + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLlengthCmd -- + * + * Procedure called to compile the "llength" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "llength" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLlengthCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitOpcode(INST_LIST_LENGTH, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLsetCmd -- + * + * Procedure called to compile the "lset" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lset" command at + * runtime. + * + * The general template for execution of the "lset" command is: + * (1) Instructions to push the variable name, unless the variable is + * local to the stack frame. + * (2) If the variable is an array element, instructions to push the + * array element name. + * (3) Instructions to push each of zero or more "index" arguments to the + * stack, followed with the "newValue" element. + * (4) Instructions to duplicate the variable name and/or array element + * name onto the top of the stack, if either was pushed at steps (1) + * and (2). + * (5) The appropriate INST_LOAD_* instruction to place the original + * value of the list variable at top of stack. + * (6) At this point, the stack contains: + * varName? arrayElementName? index1 index2 ... newValue oldList + * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST + * according as whether there is exactly one index element (LIST) or + * either zero or else two or more (FLAT). This instruction removes + * everything from the stack except for the two names and pushes the + * new value of the variable. + * (7) Finally, INST_STORE_* stores the new value in the variable and + * cleans up the stack. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLsetCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + int tempDepth; /* Depth used for emitting one part of the + * code burst. */ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the variable name. */ + int localIndex; /* Index of var in local var table. */ + int simpleVarName; /* Flag == 1 if var name is simple. */ + int isScalar; /* Flag == 1 if scalar, 0 if array. */ + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * Check argument count. + */ + + if (parsePtr->numWords < 3) { + /* + * Fail at run time, not in compilation. + */ + + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * Push the "index" args and the new element value. + */ + + for (i=2 ; i<parsePtr->numWords ; ++i) { + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, i); + } + + /* + * Duplicate the variable name if it's been pushed. + */ + + if (!simpleVarName || localIndex < 0) { + if (!simpleVarName || isScalar) { + tempDepth = parsePtr->numWords - 2; + } else { + tempDepth = parsePtr->numWords - 1; + } + TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + } + + /* + * Duplicate an array index if one's been pushed. + */ + + if (simpleVarName && !isScalar) { + if (localIndex < 0) { + tempDepth = parsePtr->numWords - 1; + } else { + tempDepth = parsePtr->numWords - 2; + } + TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + } + + /* + * Emit code to load the variable's value. + */ + + if (!simpleVarName) { + TclEmitOpcode(INST_LOAD_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr); + } + } + + /* + * Emit the correct variety of 'lset' instruction. + */ + + if (parsePtr->numWords == 4) { + TclEmitOpcode(INST_LSET_LIST, envPtr); + } else { + TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + } + + /* + * Emit code to put the value back in the variable. + */ + + if (!simpleVarName) { + TclEmitOpcode(INST_STORE_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegexpCmd -- + * + * Procedure called to compile the "regexp" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "regexp" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegexpCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the RE or string. */ + int i, len, nocase, exact, sawLast, simple; + char *str; + DefineLineInformation; /* TIP #280 */ + + /* + * We are only interested in compiling simple regexp cases. Currently + * supported compile cases are: + * regexp ?-nocase? ?--? staticString $var + * regexp ?-nocase? ?--? {^staticString$} $var + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + simple = 0; + nocase = 0; + sawLast = 0; + varTokenPtr = parsePtr->tokenPtr; + + /* + * We only look for -nocase and -- as options. Everything else gets pushed + * to runtime execution. This is different than regexp's runtime option + * handling, but satisfies our stricter needs. + */ + + for (i = 1; i < parsePtr->numWords - 2; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Not a simple string, so punt to runtime. + */ + + return TCL_ERROR; + } + str = (char *) varTokenPtr[1].start; + len = varTokenPtr[1].size; + if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { + sawLast++; + i++; + break; + } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { + nocase = 1; + } else { + /* + * Not an option we recognize. + */ + + return TCL_ERROR; + } + } + + if ((parsePtr->numWords - i) != 2) { + /* + * We don't support capturing to variables. + */ + + return TCL_ERROR; + } + + /* + * Get the regexp string. If it is not a simple string or can't be + * converted to a glob pattern, push the word for the INST_REGEXP. + * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + Tcl_DString ds; + + str = (char *) varTokenPtr[1].start; + len = varTokenPtr[1].size; + /* + * If it has a '-', it could be an incorrectly formed regexp command. + */ + + if ((*str == '-') && !sawLast) { + return TCL_ERROR; + } + + if (len == 0) { + /* + * The semantics of regexp are always match on re == "". + */ + + PushLiteral(envPtr, "1", 1); + return TCL_OK; + } + + /* + * Attempt to convert pattern to glob. If successful, push the + * converted pattern as a literal. + */ + + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + == TCL_OK) { + simple = 1; + PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } + + if (!simple) { + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); + } + + /* + * Push the string arg. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); + + if (simple) { + if (exact && !nocase) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + } + } else { + /* + * Pass correct RE compile flags. We use only Int1 (8-bit), but + * that handles all the flags we want to pass. + * Don't use TCL_REG_NOSUB as we may have backrefs. + */ + int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); + TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileReturnCmd -- + * + * Procedure called to compile the "return" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "return" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileReturnCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * General syntax: [return ?-option value ...? ?result?] + * An even number of words means an explicit result argument is present. + */ + int level, code, objc, size, status = TCL_OK; + int numWords = parsePtr->numWords; + int explicitResult = (0 == (numWords % 2)); + int numOptionWords = numWords - 1 - explicitResult; + Tcl_Obj *returnOpts, **objv; + Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + + /* + * Check for special case which can always be compiled: + * return -options <opts> <msg> + * Unlike the normal [return] compilation, this version does everything at + * runtime so it can handle arbitrary words and not just literals. Note + * that if INST_RETURN_STK wasn't already needed for something else + * ('finally' clause processing) this piece of code would not be present. + */ + + if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) + && (wordTokenPtr[1].size == 8) + && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { + Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); + Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); + + CompileWord(envPtr, optsTokenPtr, interp, 2); + CompileWord(envPtr, msgTokenPtr, interp, 3); + TclEmitOpcode(INST_RETURN_STK, envPtr); + return TCL_OK; + } + + /* + * Allocate some working space. + */ + + objv = (Tcl_Obj **) TclStackAlloc(interp, + numOptionWords * sizeof(Tcl_Obj *)); + + /* + * Scan through the return options. If any are unknown at compile time, + * there is no value in bytecompiling. Save the option values known in an + * objv array for merging into a return options dictionary. + */ + + for (objc = 0; objc < numOptionWords; objc++) { + objv[objc] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[objc]); + if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { + objc++; + status = TCL_ERROR; + goto cleanup; } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + status = TclMergeReturnOptions(interp, objc, objv, + &returnOpts, &code, &level); + cleanup: + while (--objc >= 0) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + if (TCL_ERROR == status) { + /* + * Something was bogus in the return options. Clear the error message, + * and report back to the compiler that this must be interpreted at + * runtime. + */ + + Tcl_ResetResult(interp); + return TCL_ERROR; + } + + /* + * All options are known at compile time, so we're going to bytecompile. + * Emit instructions to push the result on the stack. + */ + + if (explicitResult) { + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + } else { + /* + * No explict result argument, so default result is empty string. + */ + + PushLiteral(envPtr, "", 0); } /* - * Everything is a literal, so the result is constant too (or an error if - * the format is broken). Do the format now. + * Check for optimization: When [return] is in a proc, and there's no + * enclosing [catch], and there are no return options, then the INST_DONE + * instruction is equivalent, and may be more efficient. */ - tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), - parsePtr->numWords-2, objv); - for (; --i>=0 ;) { - Tcl_DecrRefCount(objv[i]); + if (numOptionWords == 0 && envPtr->procPtr != NULL) { + /* + * We have default return options and we're in a proc ... + */ + + int index = envPtr->exceptArrayNext - 1; + int enclosingCatch = 0; + + while (index >= 0) { + ExceptionRange range = envPtr->exceptArrayPtr[index]; + if ((range.type == CATCH_EXCEPTION_RANGE) + && (range.catchOffset == -1)) { + enclosingCatch = 1; + break; + } + index--; + } + if (!enclosingCatch) { + /* + * ... and there is no enclosing catch. Issue the maximally + * efficient exit instruction. + */ + + Tcl_DecrRefCount(returnOpts); + TclEmitOpcode(INST_DONE, envPtr); + return TCL_OK; + } } - ckfree(objv); - Tcl_DecrRefCount(formatObj); - if (tmpObj == NULL) { - TclCompileSyntaxError(interp, envPtr); + + /* Optimize [return -level 0 $x]. */ + Tcl_DictObjSize(NULL, returnOpts, &size); + if (size == 0 && level == 0 && code == TCL_OK) { + Tcl_DecrRefCount(returnOpts); return TCL_OK; } /* - * Not an error, always a constant result, so just push the result as a - * literal. Job done. + * Could not use the optimization, so we push the return options dict, and + * emit the INST_RETURN_IMM instruction with code and level as operands. */ - bytes = TclGetStringFromObj(tmpObj, &len); - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(tmpObj); + CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; +} + +static void +CompileReturnInternal( + CompileEnv *envPtr, + unsigned char op, + int code, + int level, + Tcl_Obj *returnOpts) +{ + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); + TclEmitInstInt4(op, code, envPtr); + TclEmitInt4(level, envPtr); +} + +void +TclCompileSyntaxError( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + Tcl_Obj *msg = Tcl_GetObjResult(interp); + int numBytes; + const char *bytes = TclGetStringFromObj(msg, &numBytes); + + TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, + Tcl_GetReturnOptions(interp, TCL_ERROR)); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSetCmd -- + * + * Procedure called to compile the "set" 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 + * 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); - checkForStringConcatCase: /* - * See if we can generate a sequence of things to concatenate. This - * requires that all the % sequences be %s or %%, as everything else is - * sufficiently complex that we don't bother. - * - * First, get the state of the system relatively sensible (cleaning up - * after our attempt to spot a literal). + * 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. */ - for (; i>=0 ; i--) { - Tcl_DecrRefCount(objv[i]); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * If we are doing an assignment, push the new value. + */ + + if (isAssignment) { + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); } - ckfree(objv); + + /* + * 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); - i = 0; + 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; /* - * Now scan through and check for non-%s and non-%% substitutions. + * We don't support any flags; the bytecode isn't that sophisticated. */ - for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { - if (*bytes == '%') { - bytes++; - if (*bytes == 's') { - i++; - continue; - } else if (*bytes == '%') { - continue; + 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( + 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; + + if (parsePtr->numWords != 3) { + 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) { + 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); } - Tcl_DecrRefCount(formatObj); + PushLiteral(envPtr, str, length); + } else { + SetLineInformation (i+1+nocase); + CompileTokens(envPtr, tokenPtr, interp); + } + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Push the matcher. + */ + + 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; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * Here someone is asking for the length of a static string. Just push + * the actual character (not byte) length. + */ + + char buf[TCL_INTEGER_SPACE]; + int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size); + + len = sprintf(buf, "%d", len); + PushLiteral(envPtr, buf, len); + } else { + SetLineInformation (1); + CompileTokens(envPtr, tokenPtr, interp); + TclEmitOpcode(INST_STR_LEN, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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** bodyNext; + 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 savedStackDepth = envPtr->currStackDepth; + int noCase; /* Has the -nocase flag been given? */ + int foundMode = 0; /* Have we seen a mode flag yet? */ + int i, valueIndex; + 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; + + /* + * 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). + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { return TCL_ERROR; } + + 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) { + return TCL_ERROR; + } + mode = Switch_Glob; + foundMode = 1; + valueIndex++; + continue; + } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { + if (foundMode) { + 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; + } + + /* + * 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! + */ + + return TCL_ERROR; } /* - * Check if the number of things to concatenate will fit in a byte. + * 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. */ - if (i+2 != parsePtr->numWords || i > 125) { - Tcl_DecrRefCount(formatObj); + 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. + */ + + if (numWords == 1) { + CONST char *bytes; + int maxLen, numBytes; + 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. */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + bytes = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + + /* Allocate enough space to work in. */ + maxLen = TclMaxListLength(bytes, numBytes, NULL); + if (maxLen < 2) { + return TCL_ERROR; + } + bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * maxLen); + bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * maxLen); + bodyLines = (int *) ckalloc(sizeof(int) * maxLen); + bodyNext = (int **) ckalloc(sizeof(int*) * maxLen); + + bline = mapPtr->loc[eclIndex].line[valueIndex+1]; + numWords = 0; + + while (numBytes > 0) { + CONST char *prevBytes = bytes; + int literal; + + if (TCL_OK != TclFindElement(NULL, bytes, numBytes, + &(bodyTokenArray[numWords].start), &bytes, + &(bodyTokenArray[numWords].size), &literal) || !literal) { + goto abort; + } + + bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; + bodyTokenArray[numWords].numComponents = 0; + bodyToken[numWords] = bodyTokenArray + numWords; + + /* + * 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, prevBytes, bodyTokenArray[numWords].start); + TclAdvanceContinuations (&bline, &clNext, + bodyTokenArray[numWords].start - envPtr->source); + bodyLines[numWords] = bline; + bodyNext[numWords] = clNext; + TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); + TclAdvanceContinuations (&bline, &clNext, bytes - envPtr->source); + + numBytes -= (bytes - prevBytes); + numWords++; + } + if (numWords % 2) { + abort: + ckfree((char *) bodyToken); + ckfree((char *) bodyTokenArray); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + return TCL_ERROR; + } + } 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); + bodyNext = (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) { + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + return TCL_ERROR; + } + bodyToken[i] = tokenPtr+1; + + /* + * TIP #280: Copy line information from regular cmd info. + */ + + bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; + bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; + tokenPtr = TokenAfter(tokenPtr); + } } /* - * Generate the pushes of the things to concatenate, a sequence of - * literals and compiled tokens (of which at least one is non-literal or - * we'd have the case in the first half of this function) which we will - * concatenate. + * Fall back to interpreted if the last body is a continuation (it's + * illegal, but this makes the error happen at the right time). */ - i = 0; /* The count of things to concat. */ - j = 2; /* The index into the argument tokens, for - * TIP#280 handling. */ - start = Tcl_GetString(formatObj); - /* The start of the currently-scanned literal - * in the format string. */ - tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal - * being built. */ - for (bytes = start ; *bytes ; bytes++) { - if (*bytes == '%') { - Tcl_AppendToObj(tmpObj, start, bytes - start); - if (*++bytes == '%') { - Tcl_AppendToObj(tmpObj, "%", 1); - } else { - char *b = TclGetStringFromObj(tmpObj, &len); + if (bodyToken[numWords-1]->size == 1 && + bodyToken[numWords-1]->start[0] == '-') { + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + return TCL_ERROR; + } + + /* + * Now we commit to generating code; the parsing stage per se is done. + * First, we push the value we're matching against on the stack. + */ + + SetLineInformation (valueIndex); + CompileTokens(envPtr, valueTokenPtr, interp); + + /* + * 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 (mode == Switch_Exact) { + JumptableInfo *jtPtr; + int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; + int mustGenerate, jumpToDefault; + Tcl_DString buffer; + Tcl_HashEntry *hPtr; + /* + * 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 = (int *) ckalloc(sizeof(int) * (numWords/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<numWords ; i+=2) { + /* + * For each arm, we must first work out what to do with the match + * term. + */ + + if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || + memcmp(bodyToken[numWords-2]->start, "default", 7)) { /* - * If there is a non-empty literal from the format string, - * push it and reset. + * 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. */ - if (len > 0) { - PushLiteral(envPtr, b, len); - Tcl_DecrRefCount(tmpObj); - tmpObj = Tcl_NewObj(); - i++; + 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, (ClientData) + (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 = bodyNext[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 < numWords || !foundDefault) { + finalFixups[numRealBodies++] = CurrentOffset(envPtr); /* - * Push the code to produce the string that would be - * substituted with %s, except we'll be concatenating - * directly. + * Easier by far to issue this jump as a fixed-width jump. + * Otherwise we'd need to do a lot more (and more awkward) + * rewriting when we fixed this all up. */ - CompileWord(envPtr, tokenPtr, interp, j); - tokenPtr = TokenAfter(tokenPtr); - j++; - i++; + 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); + } + + /* + * Clean up all our temporary space and return. + */ + + ckfree((char *) finalFixups); + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + return TCL_OK; + } + + /* + * Generate a test for each arm. + */ + + contFixIndex = -1; + contFixCount = 0; + fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords); + fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords); + memset(fixupTargetArray, 0, numWords * sizeof(int)); + fixupCount = 0; + foundDefault = 0; + for (i=0 ; i<numWords ; i+=2) { + int nextArmFixupIndex = -1; + + envPtr->currStackDepth = savedStackDepth + 1; + if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || + memcmp(bodyToken[numWords-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: { + int simple = 0, 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) { + if (exact && !noCase) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + } + } else { + /* + * Pass correct RE compile flags. We use only Int1 + * (8-bit), but that handles all the flags we want to + * pass. Don't use TCL_REG_NOSUB as we may have backrefs + * or capture vars. + */ + + int cflags = TCL_REG_ADVANCED + | (noCase ? TCL_REG_NOCASE : 0); + + TclEmitInstInt1(INST_REGEXP, cflags, 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 = bodyNext[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); + } + } + + /* + * Clean up all our temporary space and return. + */ + + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + + /* + * 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; + } } - start = bytes + 1; } } + ckfree((char *) fixupArray); + ckfree((char *) fixupTargetArray); + + envPtr->currStackDepth = savedStackDepth + 1; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileWhileCmd -- + * + * Procedure called to compile the "while" 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 "while" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +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. */ + 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; + } + + /* + * 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" {}". + * + * Bail out also if the body expression requires substitutions in order to + * insure correct behaviour [Bug 219166] + */ + + testTokenPtr = TokenAfter(parsePtr->tokenPtr); + bodyTokenPtr = TokenAfter(testTokenPtr); + + if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { + return TCL_ERROR; + } /* - * Handle the case of a trailing literal. + * Find out if the condition is a constant. */ - Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = TclGetStringFromObj(tmpObj, &len); - if (len > 0) { - PushLiteral(envPtr, bytes, len); - i++; + 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. + */ + + loopMayEnd = 0; + } else { + /* + * This is an empty loop: "while 0 {...}" or such. Compile no + * bytecodes. + */ + + goto pushResult; + } } - Tcl_DecrRefCount(tmpObj); - Tcl_DecrRefCount(formatObj); - if (i > 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 { /* - * Do the concatenation, which produces the result. + * Make sure that the first command in the body is preceded by an + * INST_START_CMD, and hence counted properly. [Bug 1752146] */ - TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); + 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; + } + envPtr->currStackDepth = savedStackDepth; + SetLineInformation (1); + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; + + 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); + } + } + + /* + * 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; } /* *---------------------------------------------------------------------- * - * TclLocalScalarFromToken -- + * LocalScalar(FromToken) -- * * Get the index into the table of compiled locals that corresponds * to a local scalar variable name. * * Results: * Returns the non-negative integer index value into the table of - * compiled locals corresponding to a local scalar variable name. - * If the arguments passed in do not identify a local scalar variable - * then return -1. + * compiled locals corresponding to a local scalar variable name. + * If the arguments passed in do not identify a local scalar variable + * then return -1. * * Side effects: - * May add an entery into the table of compiled locals. + * May add an entry into the table of compiled locals. * *---------------------------------------------------------------------- */ -int -TclLocalScalarFromToken( +static int +LocalScalarFromToken( Tcl_Token *tokenPtr, CompileEnv *envPtr) { - int isScalar, index; + int isSimple, isScalar, index; - TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); + PushVarName(NULL, tokenPtr, envPtr, TCL_CREATE_VAR, &index, + &isSimple, &isScalar, 0 /* ignored */, NULL /* ignored */); if (!isScalar) { index = -1; } return index; } -int -TclLocalScalar( +static int +LocalScalar( const char *bytes, int numBytes, CompileEnv *envPtr) { - Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, - {TCL_TOKEN_TEXT, NULL, 0, 0}}; + Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, + {TCL_TOKEN_TEXT, NULL, 0, 0}}; token[1].start = bytes; token[1].size = numBytes; - return TclLocalScalarFromToken(token, envPtr); + return LocalScalarFromToken(token, envPtr); } /* *---------------------------------------------------------------------- * - * TclPushVarName -- + * PushVarName -- * * Procedure used in the compiling where pushing a variable name is * necessary (append, lappend, set). * * Results: - * The values written to *localIndexPtr and *isScalarPtr signal to - * the caller what the instructions emitted by this routine will do: - * - * *isScalarPtr (*localIndexPtr < 0) - * 1 1 Push the varname on the stack. (Stack +1) - * 1 0 *localIndexPtr is the index of the compiled - * local for this varname. No instructions - * emitted. (Stack +0) - * 0 1 Push part1 and part2 names of array element - * on the stack. (Stack +2) - * 0 0 *localIndexPtr is the index of the compiled - * local for this array. Element name is pushed - * on the stack. (Stack +1) + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr. + * Instructions are added to envPtr to execute the "set" command at + * runtime. * *---------------------------------------------------------------------- */ -void -TclPushVarName( +static int +PushVarName( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ + int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */ int *localIndexPtr, /* Must not be NULL. */ - int *isScalarPtr) /* Must not be NULL. */ + int *simpleVarNamePtr, /* Must not be NULL. */ + int *isScalarPtr, /* Must not be NULL. */ + int line, /* Line the token starts on. */ + int* clNext) /* Reference to offset of next hidden cont. line */ { register const char *p; const char *name, *elName; @@ -3340,13 +4826,14 @@ TclPushVarName( } } - if (!(flags & TCL_NO_ELEMENT) && (elName != NULL) && elNameChars) { + if (interp && (elName != NULL) && elNameChars) { /* * An array element, the element name is a simple string: * assemble the corresponding token. */ - elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token)); + elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp, + sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; @@ -3359,6 +4846,7 @@ TclPushVarName( && (varTokenPtr[1].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { + /* * Check for parentheses inside first token. */ @@ -3381,9 +4869,9 @@ TclPushVarName( */ if (varTokenPtr[n].size == 1) { - n--; + --n; } else { - varTokenPtr[n].size--; + --varTokenPtr[n].size; removedParen = n; } @@ -3393,14 +4881,14 @@ TclPushVarName( remainingChars = (varTokenPtr[2].start - p) - 1; elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; - if (!(flags & TCL_NO_ELEMENT)) { - if (remainingChars) { + if (remainingChars) { /* * Make a first token with the extra characters in the first * token. */ - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); + elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp, + n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; @@ -3414,14 +4902,13 @@ TclPushVarName( memcpy(elemTokenPtr+1, varTokenPtr+2, (n-1) * sizeof(Tcl_Token)); - } else { + } else { /* * Use the already available tokens. */ elemTokenPtr = &varTokenPtr[2]; elemTokenCount = n - 1; - } } } } @@ -3432,7 +4919,6 @@ TclPushVarName( */ int hasNsQualifiers = 0; - for (i = 0, p = name; i < nameChars; i++, p++) { if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { hasNsQualifiers = 1; @@ -3446,8 +4932,10 @@ TclPushVarName( * push its name and look it up at runtime. */ - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ flags & TCL_CREATE_VAR, + envPtr->procPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { /* * We'll push the name. @@ -3461,16 +4949,16 @@ TclPushVarName( } /* - * Compile the element script, if any, and only if not inhibited. [Bug - * 3600328] + * Compile the element script, if any. */ - if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { + if (interp && elName != NULL) { if (elNameChars) { - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); + envPtr->line = line; + envPtr->clNext = clNext; + TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { - PushStringLiteral(envPtr, ""); + PushLiteral(envPtr, "", 0); } } } else if (interp) { @@ -3478,17 +4966,1415 @@ TclPushVarName( * The var name isn't simple: compile and push it. */ + envPtr->line = line; + envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } if (removedParen) { - varTokenPtr[removedParen].size++; + ++varTokenPtr[removedParen].size; } if (allocedTokens) { TclStackFree(interp, elemTokenPtr); } *localIndexPtr = localIndex; + *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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->procPtr); + 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 (envPtr->procPtr == NULL) { + 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, + /*create*/ TCL_CREATE_VAR, + envPtr->procPtr); + 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 localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *objPtr; + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords < 3) { + return TCL_ERROR; + } + + /* + * Push the frame index if it is known at compile time + */ + + objPtr = Tcl_NewObj(); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + CallFrame *framePtr; + Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; + + /* + * Attempt to convert to a level reference. Note that TclObjGetFrame + * only changes the obj type when a conversion was successful. + */ + + TclObjGetFrame(interp, objPtr, &framePtr); + newTypePtr = objPtr->typePtr; + Tcl_DecrRefCount(objPtr); + + if (newTypePtr != typePtr) { + if(numWords%2) { + return TCL_ERROR; + } + /* TODO: Push the known value instead? */ + CompileWord(envPtr, tokenPtr, interp, 1); + otherTokenPtr = TokenAfter(tokenPtr); + i = 2; + } else { + if(!(numWords%2)) { + return TCL_ERROR; + } + PushLiteral(envPtr, "1", 1); + otherTokenPtr = tokenPtr; + i = 1; + } + } else { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + for(; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, i); + localIndex = LocalScalarFromToken(localTokenPtr, envPtr); + if (localIndex < 0) { + 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 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, 2); + + /* + * 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=3; i<numWords; i+=2) { + otherTokenPtr = TokenAfter(localTokenPtr); + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, i); + localIndex = LocalScalarFromToken(localTokenPtr, envPtr); + if (localIndex < 0) { + 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=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if(localIndex < 0) { + return TCL_ERROR; + } + + /* TODO: Consider what values can pass through the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ + CompileWord(envPtr, varTokenPtr, interp, i); + 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=1; i<numWords; i+=2) { + varTokenPtr = TokenAfter(valueTokenPtr); + valueTokenPtr = TokenAfter(varTokenPtr); + + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if(localIndex < 0) { + return TCL_ERROR; + } + + /* TODO: Consider what values can pass through the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ + CompileWord(envPtr, varTokenPtr, interp, i); + TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); + + if (i != numWords-1) { + /* + * A value has been given: set the variable, pop the value + */ + + CompileWord(envPtr, valueTokenPtr, interp, i+1); + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + } + + /* + * Set the result to empty + */ + + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileEnsemble -- + * + * Procedure called to compile an ensemble command. Note that most + * ensembles are not compiled, since modifying a compiled ensemble causes + * a invalidation of all existing bytecode (expensive!) which is not + * normally warranted. + * + * 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 subcommands of the + * ensemble at runtime if a compile-time mapping is possible. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileEnsemble( + 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; + Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; + Tcl_Command ensemble = (Tcl_Command) cmdPtr; + Tcl_Parse synthetic; + int len, numBytes, result, flags = 0, i; + const char *word; + DefineLineInformation; + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard. + */ + + return TCL_ERROR; + } + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + + /* + * There's a sporting chance we'll be able to compile this. But now we + * must check properly. To do that, check that we're compiling an ensemble + * that has a compilable command as its appropriate subcommand. + */ + + if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK + || mapObj == NULL) { + /* + * Either not an ensemble or a mapping isn't installed. Crud. Too hard + * to proceed. + */ + + return TCL_ERROR; + } + + /* + * Next, get the flags. We need them on several code paths. + */ + + (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); + + /* + * Check to see if there's also a subcommand list; must check to see if + * the subcommand we are calling is in that list if it exists, since that + * list filters the entries in the map. + */ + + (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); + if (listObj != NULL) { + int sclen; + const char *str; + Tcl_Obj *matchObj = NULL; + + if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { + return TCL_ERROR; + } + for (i=0 ; i<len ; i++) { + str = Tcl_GetStringFromObj(elems[i], &sclen); + if (sclen==numBytes && !memcmp(word, str, (unsigned) numBytes)) { + /* + * Exact match! Excellent! + */ + + result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj); + if (result != TCL_OK || targetCmdObj == NULL) { + return TCL_ERROR; + } + goto doneMapLookup; + } + + /* + * Check to see if we've got a prefix match. A single prefix match + * is fine, and allows us to refine our dictionary lookup, but + * multiple prefix matches is a Bad Thing and will prevent us from + * making progress. Note that we cannot do the lookup immediately + * in the prefix case; might be another entry later in the list + * that causes things to fail. + */ + + if ((flags & TCL_ENSEMBLE_PREFIX) + && strncmp(word, str, (unsigned) numBytes) == 0) { + if (matchObj != NULL) { + return TCL_ERROR; + } + matchObj = elems[i]; + } + } + if (matchObj != NULL) { + result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj); + if (result != TCL_OK || targetCmdObj == NULL) { + return TCL_ERROR; + } + goto doneMapLookup; + } + return TCL_ERROR; + } else { + /* + * No map, so check the dictionary directly. + */ + + TclNewStringObj(subcmdObj, word, numBytes); + result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj); + TclDecrRefCount(subcmdObj); + if (result == TCL_OK && targetCmdObj != NULL) { + /* + * Got it. Skip the fiddling around with prefixes. + */ + + goto doneMapLookup; + } + + /* + * We've not literally got a valid subcommand. But maybe we have a + * prefix. Check if prefix matches are allowed. + */ + + if (flags & TCL_ENSEMBLE_PREFIX) { + Tcl_DictSearch s; + int done, matched; + Tcl_Obj *tmpObj; + + /* + * Iterate over the keys in the dictionary, checking to see if + * we're a prefix. + */ + + Tcl_DictObjFirst(NULL,mapObj,&s,&subcmdObj,&tmpObj,&done); + matched = 0; + while (!done) { + if (strncmp(TclGetString(subcmdObj), word, + (unsigned) numBytes) == 0) { + if (matched++) { + /* + * Must have matched twice! Not unique, so no point + * looking further. + */ + + break; + } + targetCmdObj = tmpObj; + } + Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done); + } + Tcl_DictObjDone(&s); + + /* + * If we have anything other than a single match, we've failed the + * unique prefix check. + */ + + if (matched != 1) { + return TCL_ERROR; + } + } else { + return TCL_ERROR; + } + } + + /* + * OK, we definitely map to something. But what? + * + * The command we map to is the first word out of the map element. Note + * that we also reject dealing with multi-element rewrites if we are in a + * safe interpreter, as there is otherwise a (highly gnarly!) way to make + * Tcl crash open to exploit. + */ + + doneMapLookup: + if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) { + return TCL_ERROR; + } + if (len > 1 && Tcl_IsSafe(interp)) { + return TCL_ERROR; + } + targetCmdObj = elems[0]; + + Tcl_IncrRefCount(targetCmdObj); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + TclDecrRefCount(targetCmdObj); + if (cmdPtr == NULL || cmdPtr->compileProc == NULL + || cmdPtr->flags & CMD_HAS_EXEC_TRACES + || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { + /* + * Maps to an undefined command or a command without a compiler. + * Cannot compile. + */ + + return TCL_ERROR; + } + + /* + * Now we've done the mapping process, can now actually try to compile. + * We do this by handing off to the subcommand's actual compiler. But to + * do that, we have to perform some trickery to rewrite the arguments. + */ + + TclParseInit(interp, NULL, 0, &synthetic); + synthetic.numWords = parsePtr->numWords - 2 + len; + TclGrowParseTokenArray(&synthetic, 2*len); + synthetic.numTokens = 2*len; + + /* + * Now we have the space to work in, install something rewritten. Note + * that we are here praying for all our might that none of these words are + * a script; the error detection code will crash if that happens and there + * is nothing we can do to avoid it! + */ + + for (i=0 ; i<len ; i++) { + int sclen; + const char *str = Tcl_GetStringFromObj(elems[i], &sclen); + + synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD; + synthetic.tokenPtr[2*i].start = str; + synthetic.tokenPtr[2*i].size = sclen; + synthetic.tokenPtr[2*i].numComponents = 1; + + synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT; + synthetic.tokenPtr[2*i+1].start = str; + synthetic.tokenPtr[2*i+1].size = sclen; + synthetic.tokenPtr[2*i+1].numComponents = 0; + } + + /* + * Copy over the real argument tokens. + */ + + for (i=len; i<synthetic.numWords; i++) { + int toCopy; + tokenPtr = TokenAfter(tokenPtr); + toCopy = tokenPtr->numComponents + 1; + TclGrowParseTokenArray(&synthetic, toCopy); + memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, + sizeof(Tcl_Token) * toCopy); + synthetic.numTokens += toCopy; + } + + /* + * Hand off compilation to the subcommand compiler. At last! + */ + + mapPtr->loc[eclIndex].line++; + mapPtr->loc[eclIndex].next++; + + result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + + mapPtr->loc[eclIndex].line--; + mapPtr->loc[eclIndex].next--; + + /* + * Clean up if necessary. + */ + + Tcl_FreeParse(&synthetic); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * 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, TCL_CREATE_VAR, &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; } /* |