diff options
Diffstat (limited to 'generic/tclCompCmds.c')
| -rw-r--r-- | generic/tclCompCmds.c | 4235 |
1 files changed, 2809 insertions, 1426 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 09c3dd0..d1d7a80 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1,81 +1,503 @@ -/* +/* * tclCompCmds.c -- * - * This file contains compilation procedures that compile various - * Tcl commands into a sequence of instructions ("bytecodes"). + * This file contains compilation procedures that compile various Tcl + * commands into a sequence of instructions ("bytecodes"). * * 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. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCompCmds.c,v 1.2 1999/04/16 00:46:43 stanton Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Prototypes for procedures defined later in this file: */ -static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); -static void FreeForeachInfo _ANSI_ARGS_(( - ClientData clientData)); +static ClientData DupDictUpdateInfo(ClientData clientData); +static void FreeDictUpdateInfo(ClientData clientData); +static void PrintDictUpdateInfo(ClientData clientData, + Tcl_Obj *appendObj, 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 PrintNewForeachInfo(ClientData clientData, + Tcl_Obj *appendObj, 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); /* * The structures below define the AuxData types defined in this file. */ -AuxDataType tclForeachInfoType = { - "ForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo /* freeProc */ +const AuxDataType tclForeachInfoType = { + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo, /* freeProc */ + PrintForeachInfo /* printProc */ +}; + +const AuxDataType tclNewForeachInfoType = { + "NewForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo, /* freeProc */ + PrintNewForeachInfo /* printProc */ +}; + +const AuxDataType tclDictUpdateInfoType = { + "DictUpdateInfo", /* name */ + DupDictUpdateInfo, /* dupProc */ + FreeDictUpdateInfo, /* freeProc */ + PrintDictUpdateInfo /* printProc */ }; /* *---------------------------------------------------------------------- * + * TclCompileAppendCmd -- + * + * Procedure called to compile the "append" 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 "append" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileAppendCmd( + 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 isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + /* TODO: Consider support for compiling expanded args. */ + numWords = parsePtr->numWords; + if (numWords == 1) { + return TCL_ERROR; + } else if (numWords == 2) { + /* + * append varName == set varName + */ + + 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. + */ + + goto appendMultiple; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &isScalar, 1); + + /* + * We are doing an assignment, otherwise TclCompileSetCmd was called, so + * push the new value. This will need to be extended to push a value for + * each argument. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); + + /* + * Emit instructions to set/get the variable. + */ + + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_APPEND_STK, envPtr); + } else { + Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); + } else { + Emit14Inst(INST_APPEND_ARRAY, 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); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &isScalar, 1); + if (!isScalar || 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; + } + + 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 (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 = AnonymousLocal(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, &tclForeachInfoType, 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; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error during compilation. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * 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 runtime. + * Instructions are added to envPtr to execute the "break" command at + * runtime. * *---------------------------------------------------------------------- */ int -TclCompileBreakCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileBreakCmd( + 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. */ { + ExceptionRange *rangePtr; + ExceptionAux *auxPtr; + if (parsePtr->numWords != 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"break\"", -1); - envPtr->maxStackDepth = 0; return TCL_ERROR; } /* - * Emit a break instruction. + * Find the innermost exception range that contains this command. */ - TclEmitOpcode(INST_BREAK, envPtr); - envPtr->maxStackDepth = 0; + 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); + return TCL_OK; } @@ -87,165 +509,269 @@ TclCompileBreakCmd(interp, parsePtr, envPtr) * Procedure called to compile the "catch" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileCatchCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the catch command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at runtime. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * 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 "catch" command - * at runtime. + * Instructions are added to envPtr to execute the "catch" command at + * runtime. * *---------------------------------------------------------------------- */ int -TclCompileCatchCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileCatchCmd( + 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. */ { JumpFixup jumpFixup; - Tcl_Token *cmdTokenPtr, *nameTokenPtr; - char *name; - int localIndex, nameChars, range, maxDepth, startOffset, jumpDist; - int code; - char buffer[32 + TCL_INTEGER_SPACE]; - - envPtr->maxStackDepth = 0; - if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"catch command ?varName?\"", -1); + Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; + int resultIndex, optsIndex, range, dropScript = 0; + DefineLineInformation; /* TIP #280 */ + int depth = TclGetStackDepth(envPtr); + + /* + * If syntax does not match what we expect for [catch], do not compile. + * Let runtime checks determine if syntax has changed. + */ + + if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { return TCL_ERROR; } /* - * If a variable was specified and the catch command is at global level - * (not in a procedure), don't compile it inline: the payoff is - * too small. + * 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) && (envPtr->procPtr == NULL)) { - return TCL_OUT_LINE_COMPILE; + if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { + return TCL_ERROR; } /* - * Make sure the variable name, if any, has no substitutions and just - * refers to a local scaler. + * Make sure the variable names, if any, have no substitutions and just + * refer to local scalars. */ - localIndex = -1; - cmdTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - if (parsePtr->numWords == 3) { - nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1); - if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - name = nameTokenPtr[1].start; - nameChars = nameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_OUT_LINE_COMPILE; + resultIndex = optsIndex = -1; + 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); + if (optsIndex < 0) { + return TCL_ERROR; } - localIndex = TclFindCompiledLocal(nameTokenPtr[1].start, - nameTokenPtr[1].size, /*create*/ 1, - /*flags*/ VAR_SCALAR, envPtr->procPtr); - } else { - return TCL_OUT_LINE_COMPILE; } } /* - * We will compile the catch command. Emit a beginCatch instruction at - * the start of the catch body: the subcommand it controls. + * We will compile the catch command. Declare the exception range that it + * uses. + * + * 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. + * [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. */ - maxDepth = 0; - - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); - - startOffset = (envPtr->codeNext - envPtr->codeStart); - envPtr->exceptArrayPtr[range].codeOffset = startOffset; - code = TclCompileCmdWord(interp, cmdTokenPtr+1, - cmdTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"catch\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; + if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + ExceptionRangeStarts(envPtr, range); + BODY(cmdTokenPtr, 1); + } else { + SetLineInformation(1); + CompileTokens(envPtr, cmdTokenPtr, interp); + 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); } - maxDepth = envPtr->maxStackDepth; - envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - startOffset; - + ExceptionRangeEnds(envPtr, range); + + /* - * The "no errors" epilogue code: store the body's result into the - * variable (if any), push "0" (TCL_OK) as the catch's "no error" - * 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. */ - if (localIndex != -1) { - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); - } + TclCheckStackDepth(depth+1, envPtr); + PushStringLiteral(envPtr, "0"); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * Emit the "error case" epilogue. Push the interpreter result and the + * return code. + */ + + ExceptionRangeTarget(envPtr, range, catchOffset); + TclSetStackDepth(depth + dropScript, envPtr); + + if (dropScript) { + TclEmitOpcode( INST_POP, envPtr); } - TclEmitOpcode(INST_POP, envPtr); - TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), - envPtr); - if (maxDepth == 0) { - maxDepth = 1; + + + /* Stack at this point is empty */ + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); + + /* Stack at this point on both branches: result returnCode */ + + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { + Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", + (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* - * The "error case" code: store the body's result into the variable (if - * any), then push the error result code. The initial PC offset here is - * the catch's error target. + * Push the return options if the caller wants them. This needs to happen + * before INST_END_CATCH */ - envPtr->exceptArrayPtr[range].catchOffset = - (envPtr->codeNext - envPtr->codeStart); - if (localIndex != -1) { - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + if (optsIndex != -1) { + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + } + + /* + * End the catch + */ + + 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). + */ + + if (optsIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* + * At this point, the top of the stack is inconveniently ordered: + * result returnCode + * Reverse the stack to store the result. + */ + + 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; + } + + /* + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. + */ + + 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; } - TclEmitOpcode(INST_POP, 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 = Tcl_GetStringFromObj(objPtr, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(objPtr); + return TCL_OK; } - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); /* - * Update the target of the jump after the "no errors" code, then emit - * an endCatch instruction at the end of the catch command. + * General case: runtime concat. */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitOpcode(INST_END_CATCH, envPtr); - done: - envPtr->exceptDepth--; - envPtr->maxStackDepth = maxDepth; - return code; + TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); + + return TCL_OK; } /* @@ -256,45 +782,1427 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) * Procedure called to compile the "continue" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * 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 runtime. + * Instructions are added to envPtr to execute the "continue" command at + * runtime. * *---------------------------------------------------------------------- */ int -TclCompileContinueCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileContinueCmd( + 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. */ { + ExceptionRange *rangePtr; + ExceptionAux *auxPtr; + /* * There should be no argument after the "continue". */ if (parsePtr->numWords != 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"continue\"", -1); - envPtr->maxStackDepth = 0; return TCL_ERROR; } /* - * Emit a continue instruction. + * See if we can find a valid continueOffset (i.e., not -1) in the + * innermost containing exception range. */ - TclEmitOpcode(INST_CONTINUE, envPtr); - envPtr->maxStackDepth = 0; + 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); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileDict*Cmd -- + * + * Functions called to compile "dict" 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 "dict" subcommand at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileDictSetCmd( + 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, dictVarIndex; + DefineLineInformation; /* TIP #280 */ + Tcl_Token *varTokenPtr; + + /* + * There must be at least one argument after the command. + */ + + if (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; + } + + /* + * Remaining words (key path and value to set) can be handled normally. + */ + + tokenPtr = TokenAfter(varTokenPtr); + for (i=2 ; i< parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Now emit the instruction to do the dict manipulation. + */ + + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); + TclEmitInt4( dictVarIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); + return TCL_OK; +} + +int +TclCompileDictIncrCmd( + 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, *keyTokenPtr; + int dictVarIndex, incrAmount; + + /* + * There must be at least two arguments after the command. + */ + + if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + keyTokenPtr = TokenAfter(varTokenPtr); + + /* + * Parse the increment amount, if present. + */ + + 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); + } + } 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. + */ + + CompileWord(envPtr, keyTokenPtr, interp, 2); + TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); + TclEmitInt4( dictVarIndex, envPtr); + return TCL_OK; +} + +int +TclCompileDictGetCmd( + 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); + + /* + * Only compile this because we need INST_DICT_GET anyway. + */ + + for (i=1 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + 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 = Tcl_GetStringFromObj(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; +} + +int +TclCompileDictForCmd( + 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_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 */ + Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; + int keyVarIndex, valueVarIndex, nameChars, 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; + + /* + * There must be three arguments after the command. + */ + + if (parsePtr->numWords != 4) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + 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); + } + } + + /* + * Check we've got a pair of variables and that they are local variables. + * 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); + } + + nameChars = strlen(argv[0]); + keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); + nameChars = strlen(argv[1]); + valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); + ckfree(argv); + + if ((keyVarIndex < 0) || (valueVarIndex < 0)) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + /* + * Allocate a temporary variable to store the iterator reference. The + * variable will contain a Tcl_DictSearch reference which will be + * allocated by INST_DICT_FIRST and disposed when the variable is unset + * (at which point it should also have been finished with). + */ + + infoIndex = AnonymousLocal(envPtr); + if (infoIndex < 0) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + /* + * 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. + */ + + CompileWord(envPtr, dictTokenPtr, interp, 2); + + /* + * 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); + 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); + + /* + * Set up the loop exception targets. + */ + + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + 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); + + /* + * Both exception target ranges (error and loop) end here. + */ + + ExceptionRangeEnds(envPtr, loopRange); + ExceptionRangeEnds(envPtr, catchRange); + + /* + * Continue (or just normally process) by getting the next pair of items + * from the dictionary and jumping back to the code to write them into + * variables if there is another pair. + */ + + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + endTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP1, 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); + + /* + * Otherwise we're done (the jump after the DICT_FIRST points here) and we + * need to pop the bogus key/value pair (pushed to keep stack calculations + * easy!) Note that we skip the END_CATCH. [Bug 1382528] + */ + + 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); + + /* + * 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. + */ + + 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, ""); + } + return TCL_OK; +} + +int +TclCompileDictUpdateCmd( + 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, 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; + } + + /* + * Parse the command. Expect the following: + * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit> + */ + + if ((parsePtr->numWords - 1) & 1) { + return TCL_ERROR; + } + numVars = (parsePtr->numWords - 3) / 2; + + /* + * 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. + */ + + dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); + dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr); + if (dictIndex < 0) { + goto issueFallback; + } + + /* + * Assemble the instruction metadata. This is complex enough that it is + * represented as auxData; it holds an ordered list of variable indices + * that are to be used. + */ + + duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); + duiPtr->length = numVars; + keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); + tokenPtr = TokenAfter(dictVarTokenPtr); + + for (i=0 ; i<numVars ; i++) { + /* + * 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). + */ + + duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); + if (duiPtr->varIndices[i] < 0) { + goto failedUpdateInfoAssembly; + } + tokenPtr = TokenAfter(tokenPtr); + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + goto failedUpdateInfoAssembly; + } + bodyTokenPtr = tokenPtr; + + /* + * The list of variables to bind is stored in auxiliary data so that it + * can't be snagged by literal sharing and forced to shimmer dangerously. + */ + + 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); + + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + + ExceptionRangeStarts(envPtr, range); + BODY(bodyTokenPtr, parsePtr->numWords - 1); + ExceptionRangeEnds(envPtr, range); + + /* + * Normal termination code: the stack has the key list below the result of + * 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); + + /* + * Jump around the exceptional termination code. + */ + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * Termination code for non-ok returns: stash the result and return + * options in the stack, bring up the key list, finish the update code, + * and finally return with the catched return data + */ + + 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); + + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitInvoke(envPtr,INST_RETURN_STK); + + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + } + 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 +TclCompileDictAppendCmd( + 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, dictVarIndex; + + /* + * 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. ;-) + */ + + /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords<4 || parsePtr->numWords>100) { + return TCL_ERROR; + } + + /* + * Get the index of the local variable that we will be working with. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); + if (dictVarIndex < 0) { + return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); + } + + /* + * Produce the string to concatenate onto the dictionary entry. + */ + + tokenPtr = TokenAfter(tokenPtr); + for (i=2 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + if (parsePtr->numWords > 4) { + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); + } + + /* + * Do the concatenation. + */ + + TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr); + return TCL_OK; +} + +int +TclCompileDictLappendCmd( + 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, *keyTokenPtr, *valueTokenPtr; + int dictVarIndex; + + /* + * 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); + } + + /* + * 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)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DupDictUpdateInfo, FreeDictUpdateInfo -- + * + * Functions to duplicate, release and print the aux data created for use + * with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions. + * + * Results: + * DupDictUpdateInfo: a copy of the auxiliary data + * FreeDictUpdateInfo: none + * PrintDictUpdateInfo: none + * + * Side effects: + * DupDictUpdateInfo: allocates memory + * FreeDictUpdateInfo: releases memory + * PrintDictUpdateInfo: none + * + *---------------------------------------------------------------------- + */ + +static ClientData +DupDictUpdateInfo( + ClientData clientData) +{ + DictUpdateInfo *dui1Ptr, *dui2Ptr; + unsigned len; + + dui1Ptr = clientData; + len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1); + dui2Ptr = ckalloc(len); + memcpy(dui2Ptr, dui1Ptr, len); + return dui2Ptr; +} + +static void +FreeDictUpdateInfo( + ClientData clientData) +{ + ckfree(clientData); +} + +static void +PrintDictUpdateInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + DictUpdateInfo *duiPtr = clientData; + int i; + + for (i=0 ; i<duiPtr->length ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ", ", -1); + } + Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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; } @@ -306,41 +2214,41 @@ TclCompileContinueCmd(interp, parsePtr, envPtr) * Procedure called to compile the "expr" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "expr" command. + * 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 runtime. + * Instructions are added to envPtr to execute the "expr" command at + * runtime. * *---------------------------------------------------------------------- */ int -TclCompileExprCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileExprCmd( + 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 *firstWordPtr; - envPtr->maxStackDepth = 0; if (parsePtr->numWords == 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"expr arg ?arg ...?\"", -1); - return TCL_ERROR; + return TCL_ERROR; } - firstWordPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), - envPtr); + /* + * TIP #280: Use the per-word line information of the current command. + */ + + envPtr->line = envPtr->extCmdMapPtr->loc[ + envPtr->extCmdMapPtr->nuloc-1].line[1]; + + firstWordPtr = TokenAfter(parsePtr->tokenPtr); + TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); + return TCL_OK; } /* @@ -351,39 +2259,32 @@ TclCompileExprCmd(interp, parsePtr, envPtr) * Procedure called to compile the "for" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * 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 runtime. + * Instructions are added to envPtr to execute the "for" command at + * runtime. * *---------------------------------------------------------------------- */ int -TclCompileForCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileForCmd( + 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 *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - JumpFixup jumpFalseFixup; - int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist; - int bodyRange, nextRange, code; - unsigned char *jumpPc; - char buffer[32 + TCL_INTEGER_SPACE]; + JumpFixup jumpEvalCondFixup; + int bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyRange, nextRange; + DefineLineInformation; /* TIP #280 */ - envPtr->maxStackDepth = 0; if (parsePtr->numWords != 5) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"for start test next command\"", -1); return TCL_ERROR; } @@ -393,173 +2294,111 @@ TclCompileForCmd(interp, parsePtr, envPtr) * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". */ - startTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1); + startTokenPtr = TokenAfter(parsePtr->tokenPtr); + testTokenPtr = TokenAfter(startTokenPtr); if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } /* - * 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). + * Bail out also if the body or the next expression require substitutions + * in order to insure correct behaviour [Bug 219166] */ - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + nextTokenPtr = TokenAfter(testTokenPtr); + bodyTokenPtr = TokenAfter(nextTokenPtr); + if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { + return TCL_ERROR; + } /* * Inline compile the initial command. */ - maxDepth = 0; - code = TclCompileCmdWord(interp, startTokenPtr+1, - startTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"for\" initial command)", -1); - } - goto done; - } - maxDepth = envPtr->maxStackDepth; + BODY(startTokenPtr, 1); TclEmitOpcode(INST_POP, envPtr); - + /* - * Compile the test then emit the conditional jump that exits the for. + * Jump to the evaluation of the condition. This code uses the "loop + * rotation" optimisation (which eliminates one branch from the loop). + * "for start cond next body" produces then: + * start + * goto A + * B: body : bodyCodeOffset + * next : nextCodeOffset, continueOffset + * A: cond -> result : testCodeOffset + * if (result) goto B */ - testCodeOffset = (envPtr->codeNext - envPtr->codeStart); - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"for\" test expression)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); /* * Compile the loop body. */ - nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); - bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); - envPtr->exceptArrayPtr[bodyRange].codeOffset = - (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, bodyTokenPtr+1, - bodyTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"for\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->exceptArrayPtr[bodyRange].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[bodyRange].codeOffset; + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); + BODY(bodyTokenPtr, 4); + ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); /* - * Compile the "next" subcommand. + * 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. */ - envPtr->exceptArrayPtr[bodyRange].continueOffset = - (envPtr->codeNext - envPtr->codeStart); - envPtr->exceptArrayPtr[nextRange].codeOffset = - (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, nextTokenPtr+1, - nextTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"for\" loop-end command)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->exceptArrayPtr[nextRange].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[nextRange].codeOffset; + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; + nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); + BODY(nextTokenPtr, 3); + ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, 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. + * Compile the test expression then emit the conditional jump that + * terminates the for. */ - jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); - jumpBackDist = (jumpBackOffset - testCodeOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { + bodyCodeOffset += 3; + nextCodeOffset += 3; + } + + SetLineInformation(2); + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); + + jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; + if (jumpDist > 127) { + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } /* - * Fix the target of the jumpFalse after the test. + * Fix the starting points of the exception ranges (may have moved due to + * jump type modification) and set where the exceptions target. */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFalseFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body and "next" command ExceptionRanges since - * they moved down. - */ + envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; + envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; - envPtr->exceptArrayPtr[bodyRange].codeOffset += 3; - envPtr->exceptArrayPtr[bodyRange].continueOffset += 3; - envPtr->exceptArrayPtr[nextRange].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ + envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); - } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); - } - } - - /* - * Set the loop's break target. - */ + ExceptionRangeTarget(envPtr, bodyRange, breakOffset); + ExceptionRangeTarget(envPtr, nextRange, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, bodyRange); + TclFinalizeLoopExceptionRange(envPtr, nextRange); - envPtr->exceptArrayPtr[bodyRange].breakOffset = - envPtr->exceptArrayPtr[nextRange].breakOffset = - (envPtr->codeNext - envPtr->codeStart); - /* * The for command's result is an empty string. */ - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } - code = TCL_OK; + PushStringLiteral(envPtr, ""); - done: - envPtr->maxStackDepth = maxDepth; - envPtr->exceptDepth--; - return code; + return TCL_OK; } /* @@ -570,334 +2409,313 @@ TclCompileForCmd(interp, parsePtr, envPtr) * Procedure called to compile the "foreach" command. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileForeachCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at 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 + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForeachCmd( + 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_KEEP_NONE); +} + +/* + *---------------------------------------------------------------------- * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. + * 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 "foreach" command - * at runtime. + * Instructions are added to envPtr to execute the "lmap" command at + * runtime. * *---------------------------------------------------------------------- */ int -TclCompileForeachCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +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; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - int firstValueTemp; /* Index of the first temp var in the frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var holding the loop's - * iteration count. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; - char *varList; - unsigned char *jumpPc; - JumpFixup jumpFalseFixup; - int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range; - int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; - char savedChar; - char buffer[32 + TCL_INTEGER_SPACE]; + int jumpBackOffset, infoIndex, range; + int numWords, numLists, numVars, loopIndex, i, j, code; + DefineLineInformation; /* TIP #280 */ /* * We parse the variable list argument words and create two arrays: - * varcList[i] is number of variables in i-th var list - * varvList[i] points to array of var names in i-th var list + * varcList[i] is number of variables in i-th var list. + * varvList[i] points to array of var names in i-th var list. */ -#define STATIC_VAR_LIST_SIZE 5 - int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; - char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; - int *varcList = varcListStaticSpace; - char ***varvList = varvListStaticSpace; + int *varcList; + const char ***varvList; /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ - envPtr->maxStackDepth = 0; if (procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; + return TCL_ERROR; } - maxDepth = 0; - numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); - return TCL_ERROR; + return TCL_ERROR; } /* - * Allocate storage for the varcList and varvList arrays if necessary. + * Bail out if the body requires substitutions in order to insure correct + * behaviour. [Bug 219166] */ - numLists = (numWords - 2)/2; - if (numLists > STATIC_VAR_LIST_SIZE) { - varcList = (int *) ckalloc(numLists * sizeof(int)); - varvList = (char ***) ckalloc(numLists * sizeof(char **)); + for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) { + tokenPtr = TokenAfter(tokenPtr); } - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - varcList[loopIndex] = 0; - varvList[loopIndex] = (char **) NULL; + bodyTokenPtr = tokenPtr; + if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; } - + /* - * Set the exception stack depth. - */ + * Allocate storage for the varcList and varvList arrays if necessary. + */ - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + numLists = (numWords - 2)/2; + varcList = TclStackAlloc(interp, numLists * sizeof(int)); + memset(varcList, 0, numLists * sizeof(int)); + varvList = (const char ***) TclStackAlloc(interp, + numLists * sizeof(const char **)); + memset((char*) varvList, 0, numLists * sizeof(const char **)); /* - * Break up each var list and set the varcList and varvList arrays. - * Don't compile the foreach inline if any var name needs substitutions - * or isn't a scalar, or if any var list needs substitutions. + * Break up each var list and set the varcList and varvList arrays. Don't + * compile the foreach inline if any var name needs substitutions or isn't + * a scalar, or if any var list needs substitutions. */ loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; - i++, tokenPtr += (tokenPtr->numComponents + 1)) { - if (i%2 == 1) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - code = TCL_OUT_LINE_COMPILE; - goto done; - } - varList = tokenPtr[1].start; - savedChar = varList[tokenPtr[1].size]; + i++, tokenPtr = TokenAfter(tokenPtr)) { + Tcl_DString varList; - /* - * Note there is a danger that modifying the string could have - * undesirable side effects. In this case, Tcl_SplitList does - * not have any dependencies on shared strings so we should be - * safe. - */ + if (i%2 != 1) { + continue; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TCL_ERROR; + goto done; + } - varList[tokenPtr[1].size] = '\0'; - code = Tcl_SplitList(interp, varList, - &varcList[loopIndex], &varvList[loopIndex]); - varList[tokenPtr[1].size] = savedChar; - if (code != TCL_OK) { - goto done; - } + /* + * Lots of copying going on here. Need a ListObj wizard to show a + * better way. + */ - numVars = varcList[loopIndex]; - for (j = 0; j < numVars; j++) { - char *varName = varvList[loopIndex][j]; - if (!TclIsLocalScalar(varName, (int) strlen(varName))) { - code = TCL_OUT_LINE_COMPILE; - goto done; - } + Tcl_DStringInit(&varList); + TclDStringAppendToken(&varList, &tokenPtr[1]); + code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList), + &varcList[loopIndex], &varvList[loopIndex]); + Tcl_DStringFree(&varList); + if (code != TCL_OK) { + code = TCL_ERROR; + goto done; + } + numVars = varcList[loopIndex]; + + /* + * 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] + */ + + if (numVars == 0) { + code = TCL_ERROR; + goto done; + } + + for (j = 0; j < numVars; j++) { + const char *varName = varvList[loopIndex][j]; + + if (!TclIsLocalScalar(varName, (int) strlen(varName))) { + code = TCL_ERROR; + goto done; } - loopIndex++; } + loopIndex++; } /* * 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. */ - firstValueTemp = -1; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); - if (loopIndex == 0) { - firstValueTemp = tempVar; - } - } - loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); - + code = TCL_OK; + /* * Create and initialize the ForeachInfo and ForeachVarList data * structures describing this command. Then create a AuxData record * pointing to the ForeachInfo structure. */ - infoPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + infoPtr = ckalloc(sizeof(ForeachInfo) + + (numLists - 1) * sizeof(ForeachVarList *)); infoPtr->numLists = numLists; - infoPtr->firstValueTemp = firstValueTemp; - infoPtr->loopCtTemp = loopCtTemp; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; + numVars = varcList[loopIndex]; - varListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + (numVars * sizeof(int))); + varListPtr = ckalloc(sizeof(ForeachVarList) + + (numVars - 1) * sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { - char *varName = varvList[loopIndex][j]; + const char *varName = varvList[loopIndex][j]; int nameChars = strlen(varName); + varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, - nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + nameChars, /*create*/ 1, envPtr); } infoPtr->varLists[loopIndex] = varListPtr; } - infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); /* - * Evaluate then store each value list in the associated temporary. + * Create the collecting object, unshared. */ - - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - loopIndex = 0; + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt4(INST_LIST, 0, envPtr); + } + + /* + * Evaluate each value list and leave it on stack. + */ + for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; - i++, tokenPtr += (tokenPtr->numComponents + 1)) { + i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - code = TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - - tempVar = (firstValueTemp + loopIndex); - if (tempVar <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - loopIndex++; + CompileWord(envPtr, tokenPtr, interp, i); } } - bodyTokenPtr = tokenPtr; - - /* - * Initialize the temporary var that holds the count of loop iterations. - */ - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Top of loop code: assign each loop variable and check whether - * to terminate the loop. - */ - - envPtr->exceptArrayPtr[range].continueOffset = - (envPtr->codeNext - envPtr->codeStart); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); /* * Inline compile the loop body. */ - envPtr->exceptArrayPtr[range].codeOffset = - (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, bodyTokenPtr+1, - bodyTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"foreach\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[range].codeOffset; - TclEmitOpcode(INST_POP, 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. - */ + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); - jumpBackDist = - (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + ExceptionRangeStarts(envPtr, range); + BODY(bodyTokenPtr, numWords - 1); + ExceptionRangeEnds(envPtr, range); + + if (collect == TCL_EACH_COLLECT) { + TclEmitOpcode(INST_LMAP_COLLECT, envPtr); } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* - * Fix the target of the jump after the foreach_step test. + * Bottom of loop code: assign each loop variable and check whether + * to terminate the loop. Set the loop's break target. */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFalseFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 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); - } - } + 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); /* - * Set the loop's break target. + * Set the jumpback distance from INST_FOREACH_STEP to the start of the + * body's code. Misuse loopCtTemp for storing the jump size. */ - - envPtr->exceptArrayPtr[range].breakOffset = - (envPtr->codeNext - envPtr->codeStart); + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + envPtr->exceptArrayPtr[range].codeOffset; + infoPtr->loopCtTemp = -jumpBackOffset; + /* - * The foreach command's result is an empty string. + * The command's result is an empty string if not collecting. If + * collecting, it is automatically left on stack after FOREACH_END. */ - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - if (maxDepth == 0) { - maxDepth = 1; + if (collect != TCL_EACH_COLLECT) { + PushStringLiteral(envPtr, ""); } - + done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - if (varvList[loopIndex] != (char **) NULL) { - ckfree((char *) varvList[loopIndex]); - } - } - if (varcList != varcListStaticSpace) { - ckfree((char *) varcList); - ckfree((char *) varvList); + if (varvList[loopIndex] != NULL) { + ckfree(varvList[loopIndex]); + } } - envPtr->maxStackDepth = maxDepth; - envPtr->exceptDepth--; + TclStackFree(interp, (void *)varvList); + TclStackFree(interp, varcList); return code; } @@ -906,8 +2724,8 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) * * DupForeachInfo -- * - * This procedure duplicates a ForeachInfo structure created as - * auxiliary data during the compilation of a foreach command. + * This procedure duplicates a ForeachInfo structure created as auxiliary + * data during the compilation of a foreach command. * * Results: * A pointer to a newly allocated copy of the existing ForeachInfo @@ -915,42 +2733,41 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) * * Side effects: * Storage for the copied ForeachInfo record is allocated. If the - * original ForeachInfo structure pointed to any ForeachVarList - * records, these structures are also copied and pointers to them - * are stored in the new ForeachInfo record. + * original ForeachInfo structure pointed to any ForeachVarList records, + * these structures are also copied and pointers to them are stored in + * the new ForeachInfo record. * *---------------------------------------------------------------------- */ static ClientData -DupForeachInfo(clientData) - ClientData clientData; /* The foreach command's compilation - * auxiliary data to duplicate. */ +DupForeachInfo( + ClientData clientData) /* The foreach command's compilation auxiliary + * data to duplicate. */ { - register ForeachInfo *srcPtr = (ForeachInfo *) clientData; + register ForeachInfo *srcPtr = clientData; ForeachInfo *dupPtr; register ForeachVarList *srcListPtr, *dupListPtr; - int numLists = srcPtr->numLists; - int numVars, i, j; - - dupPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + int numVars, i, j, numLists = srcPtr->numLists; + + dupPtr = ckalloc(sizeof(ForeachInfo) + + numLists * sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; - + for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); + dupListPtr = ckalloc(sizeof(ForeachVarList) + + numVars * sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; } dupPtr->varLists[i] = dupListPtr; } - return (ClientData) dupPtr; + return dupPtr; } /* @@ -973,624 +2790,381 @@ DupForeachInfo(clientData) */ static void -FreeForeachInfo(clientData) - ClientData clientData; /* The foreach command's compilation - * auxiliary data to free. */ +FreeForeachInfo( + ClientData clientData) /* The foreach command's compilation auxiliary + * data to free. */ { - register ForeachInfo *infoPtr = (ForeachInfo *) clientData; + register ForeachInfo *infoPtr = clientData; register ForeachVarList *listPtr; int numLists = infoPtr->numLists; register int i; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; - ckfree((char *) listPtr); + ckfree(listPtr); } - ckfree((char *) infoPtr); + ckfree(infoPtr); } /* *---------------------------------------------------------------------- * - * TclCompileIfCmd -- + * PrintForeachInfo -- * - * Procedure called to compile the "if" command. + * Function to write a human-readable representation of a ForeachInfo + * structure to stdout for debugging. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileIfCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the if command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at runtime. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * None. * * Side effects: - * Instructions are added to envPtr to execute the "if" command - * at runtime. + * None. * *---------------------------------------------------------------------- */ -int -TclCompileIfCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +static void +PrintForeachInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) { - 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 jumpDist, jumpFalseDist, jumpIndex; - int numWords, wordIdx, numBytes, maxDepth, j, code; - char *word; - char buffer[100]; - - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); - maxDepth = 0; - code = TCL_OK; + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; - /* - * Each iteration of this loop compiles one "if expr ?then? body" - * or "elseif expr ?then? body" clause. - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - numWords = parsePtr->numWords; - while (wordIdx < numWords) { - /* - * Stop looping if the token isn't "if" or "elseif". - */ + Tcl_AppendToObj(appendObj, "data=[", -1); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - break; + for (i=0 ; i<infoPtr->numLists ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ", ", -1); } - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { - tokenPtr += (tokenPtr->numComponents + 1); - wordIdx++; - } else { - break; - } - if (wordIdx >= numWords) { - sprintf(buffer, - "wrong # args: no expression after \"%.30s\" argument", - word); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); - code = TCL_ERROR; - goto done; + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) (infoPtr->firstValueTemp + i)); + } + Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", + (unsigned) infoPtr->loopCtTemp); + for (i=0 ; i<infoPtr->numLists ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ",", -1); } - - /* - * Compile the test expression then emit the conditional jump - * around the "then" part. If the expression word isn't simple, - * we back off and compile the if command out-of-line. - */ - - testTokenPtr = tokenPtr; - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"if\" test expression)", -1); + Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", + (unsigned) (infoPtr->firstValueTemp + i)); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + if (j) { + Tcl_AppendToObj(appendObj, ", ", -1); } - goto done; + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFalseFixupArray.fixup[jumpIndex])); - - /* - * Skip over the optional "then" before the then clause. - */ + Tcl_AppendToObj(appendObj, "]", -1); + } +} - tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); - wordIdx++; - if (wordIdx >= numWords) { - sprintf(buffer, "wrong # args: no script following \"%.20s\" argument", testTokenPtr->start); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); - code = TCL_ERROR; - goto done; +static void +PrintNewForeachInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + infoPtr->loopCtTemp); + for (i=0 ; i<infoPtr->numLists ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ",", -1); } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr += (tokenPtr->numComponents + 1); - wordIdx++; - if (wordIdx >= numWords) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"then\" argument", -1); - code = TCL_ERROR; - goto done; - } + Tcl_AppendToObj(appendObj, "[", -1); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + if (j) { + Tcl_AppendToObj(appendObj, ",", -1); } + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); } + Tcl_AppendToObj(appendObj, "]", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileFormatCmd -- + * + * Procedure called to compile the "format" command. Handles cases that + * can be done as constants or simple string concatenation only. + * + * 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 "format" command at + * runtime. + * + *---------------------------------------------------------------------- + */ - /* - * Compile the "then" command body. - */ +int +TclCompileFormatCmd( + 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 = parsePtr->tokenPtr; + Tcl_Obj **objv, *formatObj, *tmpObj; + char *bytes, *start; + int i, j, len; - code = TclCompileCmdWord(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"if\" then script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + /* + * Don't handle any guaranteed-error cases. + */ - /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray and - * jumpEndFixupArray are indexed by "jumpIndex". - */ + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } - 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. - */ + /* + * Check if the argument words are all compile-time-known literals; that's + * a case we can handle by compiling to a constant. + */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - if (TclFixupForwardJump(envPtr, - &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. - */ + formatObj = Tcl_NewObj(); + Tcl_IncrRefCount(formatObj); + tokenPtr = TokenAfter(tokenPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; + } - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + 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; } - - tokenPtr += (tokenPtr->numComponents + 1); - wordIdx++; } /* - * Check for the optional else clause. + * Everything is a literal, so the result is constant too (or an error if + * the format is broken). Do the format now. */ - 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 += (tokenPtr->numComponents + 1); - wordIdx++; - if (wordIdx >= numWords) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"else\" argument", -1); - code = TCL_ERROR; - goto done; - } - } + tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), + parsePtr->numWords-2, objv); + for (; --i>=0 ;) { + Tcl_DecrRefCount(objv[i]); + } + ckfree(objv); + Tcl_DecrRefCount(formatObj); + if (tmpObj == NULL) { + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; + } - /* - * Compile the else command body. - */ - - code = TclCompileCmdWord(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"if\" else script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + /* + * Not an error, always a constant result, so just push the result as a + * literal. Job done. + */ - /* - * Make sure there are no words after the else clause. - */ - - wordIdx++; - if (wordIdx < numWords) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: extra words after \"else\" clause in \"if\" command", -1); - code = TCL_ERROR; - goto done; - } - } else { - /* - * No else clause: the "if" command's result is an empty string. - */ + bytes = Tcl_GetStringFromObj(tmpObj, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(tmpObj); + return TCL_OK; - TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr); - maxDepth = TclMax(1, maxDepth); + 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). + */ + + for (; i>=0 ; i--) { + Tcl_DecrRefCount(objv[i]); } + ckfree(objv); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + tokenPtr = TokenAfter(tokenPtr); + i = 0; /* - * Fix the unconditional jumps to the end of the "if" command. + * Now scan through and check for non-%s and non-%% substitutions. */ - - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpEndFixupArray.fixup[jumpIndex].codeOffset; - if (TclFixupForwardJump(envPtr, - &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 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 { - panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); + for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { + if (*bytes == '%') { + bytes++; + if (*bytes == 's') { + i++; + continue; + } else if (*bytes == '%') { + continue; } + Tcl_DecrRefCount(formatObj); + return TCL_ERROR; } } - + /* - * Free the jumpFixupArray array if malloc'ed storage was used. + * Check if the number of things to concatenate will fit in a byte. */ - done: - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); - envPtr->maxStackDepth = maxDepth; - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIncrCmd -- - * - * Procedure called to compile the "incr" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If the command is too complex for TclCompileIncrCmd, - * TCL_OUT_LINE_COMPILE is returned indicating that the incr command - * should be compiled "out of line" by emitting code to invoke its - * command procedure at runtime. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "incr" command. - * - * Side effects: - * Instructions are added to envPtr to execute the "incr" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIncrCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *incrTokenPtr; - Tcl_Parse elemParse; - int gotElemParse = 0; - char *name, *elName, *p; - int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code; - int maxDepth = 0; - char buffer[160]; - - envPtr->maxStackDepth = 0; - if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"incr varName ?increment?\"", -1); + if (i+2 != parsePtr->numWords || i > 125) { + Tcl_DecrRefCount(formatObj); return TCL_ERROR; } - - name = NULL; - elName = NULL; - elNameChars = 0; - localIndex = -1; - code = TCL_OK; - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - for (i = 0, p = name; i < nameChars; i++, p++) { - if (*p == '(') { - char *openParen = p; - p = (name + nameChars-1); - if (*p == ')') { /* last char is ')' => array reference */ - nameChars = (openParen - name); - elName = openParen+1; - elNameChars = (p - elName); - } - break; - } - } - if (envPtr->procPtr != NULL) { - localIndex = TclFindCompiledLocal(name, nameChars, - /*create*/ 0, /*flags*/ 0, envPtr->procPtr); - if (localIndex > 255) { /* we'll push the name */ - localIndex = -1; - } - } - if (localIndex < 0) { - TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, - /*onHeap*/ 0), envPtr); - maxDepth = 1; - } - - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - /* - * Temporarily replace the '(' and ')' by '"'s. - */ - - *(elName-1) = '"'; - *(elName+elNameChars) = '"'; - code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, - /*nested*/ 0, &elemParse); - *(elName-1) = '('; - *(elName+elNameChars) = ')'; - gotElemParse = 1; - if ((code != TCL_OK) || (elemParse.numWords > 1)) { - sprintf(buffer, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, buffer, -1); - code = TCL_ERROR; - goto done; - } else if (elemParse.numWords == 1) { - code = TclCompileTokens(interp, elemParse.tokenPtr+1, - elemParse.tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; - } else { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, - /*alreadyAlloced*/ 0), envPtr); - maxDepth += 1; - } - } - } else { - /* - * Not a simple variable name. Look it up at runtime. - */ - - code = TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - } - /* - * If an increment is given, push it, but see first if it's a small - * integer. + * 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. */ - haveImmValue = 0; - immValue = 0; - if (parsePtr->numWords == 3) { - incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - char *word = incrTokenPtr[1].start; - int numBytes = incrTokenPtr[1].size; - char savedChar = word[numBytes]; - long n; - - /* - * Note there is a danger that modifying the string could have - * undesirable side effects. In this case, TclLooksLikeInt and - * TclGetLong do not have any dependencies on shared strings so we - * should be safe. - */ - - word[numBytes] = '\0'; - if (TclLooksLikeInt(word, numBytes) - && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) { - if ((-127 <= n) && (n <= 127)) { - haveImmValue = 1; - immValue = n; - } - } - word[numBytes] = savedChar; - if (!haveImmValue) { - TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes, - /*onHeap*/ 0), envPtr); - maxDepth += 1; - } - } else { - code = TclCompileTokens(interp, incrTokenPtr+1, - incrTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (increment expression)", -1); + 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 = Tcl_GetStringFromObj(tmpObj, &len); + + /* + * If there is a non-empty literal from the format string, + * push it and reset. + */ + + if (len > 0) { + PushLiteral(envPtr, b, len); + Tcl_DecrRefCount(tmpObj); + tmpObj = Tcl_NewObj(); + i++; } - goto done; + + /* + * Push the code to produce the string that would be + * substituted with %s, except we'll be concatenating + * directly. + */ + + CompileWord(envPtr, tokenPtr, interp, j); + tokenPtr = TokenAfter(tokenPtr); + j++; + i++; } - maxDepth += envPtr->maxStackDepth; + start = bytes + 1; } - } else { /* no incr amount given so use 1 */ - haveImmValue = 1; - immValue = 1; } - + /* - * Emit the instruction to increment the variable. + * Handle the case of a trailing literal. */ - if (name != NULL) { - if (elName == NULL) { - 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); - } + Tcl_AppendToObj(tmpObj, start, bytes - start); + bytes = Tcl_GetStringFromObj(tmpObj, &len); + if (len > 0) { + PushLiteral(envPtr, bytes, len); + i++; } - - done: - if (gotElemParse) { - Tcl_FreeParse(&elemParse); + Tcl_DecrRefCount(tmpObj); + Tcl_DecrRefCount(formatObj); + + if (i > 1) { + /* + * Do the concatenation, which produces the result. + */ + + TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); + } else { + /* + * EVIL HACK! Force there to be a string representation in the case + * where there's just a "%s" in the format; case covered by the test + * format-20.1 (and it is horrible...) + */ + + TclEmitOpcode(INST_DUP, envPtr); + PushStringLiteral(envPtr, ""); + TclEmitOpcode(INST_STR_EQ, envPtr); + TclEmitOpcode(INST_POP, envPtr); } - envPtr->maxStackDepth = maxDepth; - return code; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclCompileSetCmd -- + * TclPushVarName -- * - * Procedure called to compile the "set" command. + * Procedure used in the compiling where pushing a variable name is + * necessary (append, lappend, set). * * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. If - * complation fails because the set command requires a second level of - * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * set command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_SetCmd) at runtime. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the incr command. + * 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) * * Side effects: - * Instructions are added to envPtr to execute the "set" command - * at runtime. + * Instructions are added to envPtr. * *---------------------------------------------------------------------- */ -int -TclCompileSetCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclPushVarName( + 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 *localIndexPtr, /* Must not be NULL. */ + int *isScalarPtr) /* Must not be NULL. */ { - Tcl_Token *varTokenPtr, *valueTokenPtr; - Tcl_Parse elemParse; - int gotElemParse = 0; - register char *p; - char *name, *elName; - int nameChars, elNameChars; - register int i; - int isAssignment, simpleVarName, localIndex, numWords; - int maxDepth = 0; - int code = TCL_OK; - - envPtr->maxStackDepth = 0; - numWords = parsePtr->numWords; - if ((numWords != 2) && (numWords != 3)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"set varName ?newValue?\"", -1); - return TCL_ERROR; - } - isAssignment = (numWords == 3); + register const char *p; + const char *name, *elName; + register int i, n; + Tcl_Token *elemTokenPtr = NULL; + int nameChars, elNameChars, simpleVarName, localIndex; + int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; /* - * 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. + * 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. */ simpleVarName = 0; @@ -1598,47 +3172,121 @@ TclCompileSetCmd(interp, parsePtr, envPtr) nameChars = elNameChars = 0; localIndex = -1; - varTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether + * curly braces surround the variable name. This really matters for array + * elements to handle things like + * set {x($foo)} 5 + * which raises an undefined var error if we are not careful here. + */ + + if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && + (varTokenPtr->start[0] != '{')) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + simpleVarName = 1; + name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; - /* last char is ')' => potential array reference */ - if ( *(name + nameChars - 1) == ')') { - for (i = 0, p = name; i < nameChars; i++, p++) { + if (name[nameChars-1] == ')') { + /* + * last char is ')' => potential array reference. + */ + + for (i=0,p=name ; i<nameChars ; i++,p++) { if (*p == '(') { elName = p + 1; elNameChars = nameChars - i - 2; - nameChars = i ; + nameChars = i; break; } } - } + if ((elName != NULL) && elNameChars) { + /* + * An array element, the element name is a simple string: + * assemble the corresponding token. + */ + + elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token)); + allocedTokens = 1; + elemTokenPtr->type = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = elNameChars; + elemTokenPtr->numComponents = 0; + elemTokenCount = 1; + } + } + } else if (((n = varTokenPtr->numComponents) > 1) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { /* - * If elName contains any double quotes ("), we can't inline - * compile the element script using the replace '()' by '"' - * technique below. + * Check for parentheses inside first token. */ - for (i = 0, p = elName; i < elNameChars; i++, p++) { - if (*p == '"') { - simpleVarName = 0; + simpleVarName = 0; + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { + if (*p == '(') { + simpleVarName = 1; break; } } - } else if ((varTokenPtr->numComponents == 4) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[1].start[varTokenPtr[1].size-1] == '(') - && (varTokenPtr[4].type == TCL_TOKEN_TEXT) - && (varTokenPtr[4].size == 1) - && (varTokenPtr[4].start[0] == ')')) { - simpleVarName = 1; - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size - 1; - elName = varTokenPtr[2].start; - elNameChars = varTokenPtr[2].size; + if (simpleVarName) { + int remainingChars; + + /* + * Check the last token: if it is just ')', do not count it. + * Otherwise, remove the ')' and flag so that it is restored at + * the end. + */ + + if (varTokenPtr[n].size == 1) { + n--; + } else { + varTokenPtr[n].size--; + removedParen = n; + } + + name = varTokenPtr[1].start; + nameChars = p - varTokenPtr[1].start; + elName = p + 1; + remainingChars = (varTokenPtr[2].start - p) - 1; + elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; + + if (remainingChars) { + /* + * Make a first token with the extra characters in the first + * token. + */ + + elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); + allocedTokens = 1; + elemTokenPtr->type = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = remainingChars; + elemTokenPtr->numComponents = 0; + elemTokenCount = n; + + /* + * Copy the remaining tokens. + */ + + memcpy(elemTokenPtr+1, varTokenPtr+2, + (n-1) * sizeof(Tcl_Token)); + } else { + /* + * Use the already available tokens. + */ + + elemTokenPtr = &varTokenPtr[2]; + elemTokenCount = n - 1; + } + } } if (simpleVarName) { @@ -1647,67 +3295,45 @@ TclCompileSetCmd(interp, parsePtr, envPtr) */ int hasNsQualifiers = 0; + for (i = 0, p = name; i < nameChars; i++, p++) { if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { hasNsQualifiers = 1; break; } } - + /* - * Look up the var name's index in the array of local vars in the - * proc frame. If retrieving the var's value and it doesn't already - * exist, push its name and look it up at runtime. + * Look up the var name's index in the array of local vars in the proc + * frame. If retrieving the var's value and it doesn't already exist, + * push its name and look it up at runtime. */ - if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - /*create*/ isAssignment, - /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), - envPtr->procPtr); + if (!hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { + /* + * We'll push the name. + */ + + localIndex = -1; + } } - if (localIndex >= 0) { - maxDepth = 0; - } else { - TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, - /*onHeap*/ 0), envPtr); - maxDepth = 1; + if (localIndex < 0) { + PushLiteral(envPtr, name, nameChars); } /* - * Compile the element script, if any. + * Compile the element script, if any, and only if not inhibited. [Bug + * 3600328] */ - - if (elName != NULL) { - /* - * Temporarily replace the '(' and ')' by '"'s. - */ - *(elName-1) = '"'; - *(elName+elNameChars) = '"'; - code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, - /*nested*/ 0, &elemParse); - *(elName-1) = '('; - *(elName+elNameChars) = ')'; - gotElemParse = 1; - if ((code != TCL_OK) || (elemParse.numWords > 1)) { - char buffer[160]; - sprintf(buffer, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, buffer, -1); - code = TCL_ERROR; - goto done; - } else if (elemParse.numWords == 1) { - code = TclCompileTokens(interp, elemParse.tokenPtr+1, - elemParse.tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; + if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { + if (elNameChars) { + TclCompileTokens(interp, elemTokenPtr, elemTokenCount, + envPtr); } else { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, - /*alreadyAlloced*/ 0), envPtr); - maxDepth += 1; + PushStringLiteral(envPtr, ""); } } } else { @@ -1715,266 +3341,23 @@ TclCompileSetCmd(interp, parsePtr, envPtr) * The var name isn't simple: compile and push it. */ - code = TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; + CompileTokens(envPtr, varTokenPtr, interp); } - - /* - * If we are doing an assignment, push the new value. - */ - - if (isAssignment) { - valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); - if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start, - valueTokenPtr[1].size, /*onHeap*/ 0), envPtr); - maxDepth += 1; - } else { - code = TclCompileTokens(interp, valueTokenPtr+1, - valueTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; - } - } - - /* - * Emit instructions to set/get the variable. - */ - if (simpleVarName) { - if (elName == NULL) { - if (localIndex >= 0) { - 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 { - TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); - } - } else { - if (localIndex >= 0) { - 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_ARRAY_STK : INST_LOAD_ARRAY_STK), - envPtr); - } - } - } else { - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), - envPtr); + if (removedParen) { + varTokenPtr[removedParen].size++; } - - done: - if (gotElemParse) { - Tcl_FreeParse(&elemParse); + if (allocedTokens) { + TclStackFree(interp, elemTokenPtr); } - envPtr->maxStackDepth = maxDepth; - return code; + *localIndexPtr = localIndex; + *isScalarPtr = (elName == NULL); } /* - *---------------------------------------------------------------------- - * - * TclCompileWhileCmd -- - * - * Procedure called to compile the "while" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If compilation failed because the command is too - * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the while command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. - * - * Side effects: - * Instructions are added to envPtr to execute the "while" command - * at runtime. - * - *---------------------------------------------------------------------- + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: */ - -int -TclCompileWhileCmd(interp, parsePtr, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Points to a parse structure for the - * command created by Tcl_ParseCommand. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - Tcl_Token *testTokenPtr, *bodyTokenPtr; - JumpFixup jumpFalseFixup; - unsigned char *jumpPc; - int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset; - int range, maxDepth, code; - char buffer[32 + TCL_INTEGER_SPACE]; - - envPtr->maxStackDepth = 0; - maxDepth = 0; - if (parsePtr->numWords != 3) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"while test command\"", -1); - 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" {}". - */ - - testTokenPtr = parsePtr->tokenPtr - + (parsePtr->tokenPtr->numComponents + 1); - if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_OUT_LINE_COMPILE; - } - - /* - * Create a ExceptionRange record for the loop body. This is used to - * implement break and continue. - */ - - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->exceptArrayPtr[range].continueOffset = - (envPtr->codeNext - envPtr->codeStart); - - /* - * Compile the test expression then emit the conditional jump that - * terminates the while. We already know it's a simple word. - */ - - testCodeOffset = (envPtr->codeNext - envPtr->codeStart); - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"while\" test expression)", -1); - } - goto error; - } - maxDepth = envPtr->maxStackDepth; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - - /* - * Compile the loop body. - */ - - bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); - envPtr->exceptArrayPtr[range].codeOffset = - (envPtr->codeNext - envPtr->codeStart); - code = TclCompileCmdWord(interp, bodyTokenPtr+1, - bodyTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"while\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto error; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[range].codeOffset; - TclEmitOpcode(INST_POP, 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 = (envPtr->codeNext - envPtr->codeStart); - jumpBackDist = (jumpBackOffset - testCodeOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); - } - - /* - * Fix the target of the jumpFalse after the test. - */ - - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFalseFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 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 loop's break target. - */ - - envPtr->exceptArrayPtr[range].breakOffset = - (envPtr->codeNext - envPtr->codeStart); - - /* - * The while command's result is an empty string. - */ - - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } - envPtr->maxStackDepth = maxDepth; - envPtr->exceptDepth--; - return TCL_OK; - - error: - envPtr->maxStackDepth = maxDepth; - envPtr->exceptDepth--; - return code; -} - - - |