diff options
Diffstat (limited to 'generic/tclCompCmds.c')
| -rw-r--r-- | generic/tclCompCmds.c | 6484 |
1 files changed, 1739 insertions, 4745 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9eb74f5..a39370e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1,49 +1,54 @@ -/* +/* * 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-2006 by Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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" /* - * Macro that encapsulates an efficiency trick that avoids a function call for - * the simplest of compiles. The ANSI C "prototype" for this macro is: - * - * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); + * Prototypes for procedures defined later in this file: */ -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ - } +static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); +static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData)); +#ifndef TCL_TIP280 +static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, + int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr)); + +#define TclPushVarNameWord(i,v,e,f,l,s,sc,word) \ + TclPushVarName (i,v,e,f,l,s,sc) /* ignoring word */ + +#define DefineLineInformation /**/ +#define SetLineInformation(word) /**/ +#else +static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, + int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, + int line, int* clNext)); + +#define TclPushVarNameWord(i,v,e,f,l,s,sc,word) \ + TclPushVarName (i,v,e,f,l,s,sc, \ + mapPtr->loc [eclIndex].line [(word)], \ + mapPtr->loc [eclIndex].next [(word)]) -/* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. +/* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation may + * reallocate, i.e. move, the array. This is also the reason to save the nuloc + * now, it may change during the course of the function. * - * Macro to encapsulate the variable definition and setup. + * Macros to encapsulate the variable definition and setup, and their use. */ - #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 @@ -51,163 +56,23 @@ #define SetLineInformation(word) \ envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \ envPtr->clNext = mapPtr->loc [eclIndex].next [(word)] +#endif /* - * Convenience macro for use when compiling bodies of commands. The ANSI C - * "prototype" for this macro is: - * - * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); - */ - -#define CompileBody(envPtr, tokenPtr, interp) \ - TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)) - -/* - * Convenience macro for use when compiling tokens to be pushed. The ANSI C - * "prototype" for this macro is: - * - * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); - */ - -#define CompileTokens(envPtr, tokenPtr, interp) \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); -/* - * Convenience macro for use when pushing literals. The ANSI C "prototype" for - * this macro is: - * - * static void PushLiteral(CompileEnv *envPtr, - * const char *string, int length); - */ - -#define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) - -/* - * Macro to advance to the next token; it is more mnemonic than the address - * arithmetic that it replaces. The ANSI C "prototype" for this macro is: - * - * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr); - */ - -#define TokenAfter(tokenPtr) \ - ((tokenPtr) + ((tokenPtr)->numComponents + 1)) - -/* - * Macro to get the offset to the next instruction to be issued. The ANSI C - * "prototype" for this macro is: - * - * static int CurrentOffset(CompileEnv *envPtr); - */ - -#define CurrentOffset(envPtr) \ - ((envPtr)->codeNext - (envPtr)->codeStart) - -/* - * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the - * maximal depth of nested CATCH ranges in order to alloc runtime - * memory. These macros should compute precisely that? OTOH, the nesting depth - * of LOOP ranges is an interesting datum for debugging purposes, and that is - * what we compute now. - * - * static int DeclareExceptionRange(CompileEnv *envPtr, int type); - * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); - * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); - * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); - */ - -#define DeclareExceptionRange(envPtr, type) \ - (TclCreateExceptRange((type), (envPtr))) -#define ExceptionRangeStarts(envPtr, index) \ - (((envPtr)->exceptDepth++), \ - ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ - ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) -#define ExceptionRangeEnds(envPtr, index) \ - (((envPtr)->exceptDepth--), \ - ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) -#define ExceptionRangeTarget(envPtr, index, targetType) \ - ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) - -/* - * Prototypes for procedures defined later in this file: + * Flags bits used by TclPushVarName. */ -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 ClientData DupJumptableInfo(ClientData clientData); -static void FreeJumptableInfo(ClientData clientData); -static void PrintJumptableInfo(ClientData clientData, - Tcl_Obj *appendObj, ByteCode *codePtr, - unsigned int pcOffset); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, - int line, int* clNext); -static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, const char *identity, - int instruction, CompileEnv *envPtr); -static int CompileComparisonOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int instruction, - CompileEnv *envPtr); -static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int instruction, - CompileEnv *envPtr); -static int CompileUnaryOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int instruction, - CompileEnv *envPtr); -static void CompileReturnInternal(CompileEnv *envPtr, - unsigned char op, int code, int level, - Tcl_Obj *returnOpts); - -#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - PushVarName (i,v,e,f,l,s,sc, \ - mapPtr->loc [eclIndex].line [(word)], \ - mapPtr->loc [eclIndex].next [(word)]) - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ -#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ +#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ +#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. */ AuxDataType tclForeachInfoType = { - "ForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo, /* freeProc */ - PrintForeachInfo /* printProc */ -}; - -AuxDataType tclJumptableInfoType = { - "JumptableInfo", /* name */ - DupJumptableInfo, /* dupProc */ - FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo /* printProc */ -}; - -AuxDataType tclDictUpdateInfoType = { - "DictUpdateInfo", /* name */ - DupDictUpdateInfo, /* dupProc */ - FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo /* printProc */ + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ }; /* @@ -218,68 +83,89 @@ AuxDataType tclDictUpdateInfoType = { * Procedure called to compile the "append" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 + * compilation fails because the command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_AppendObjCmd) at runtime. * * Side effects: - * Instructions are added to envPtr to execute the "append" command at - * runtime. + * 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. */ +TclCompileAppendCmd(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, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; - DefineLineInformation; /* TIP #280 */ + int code = TCL_OK; + + DefineLineInformation; numWords = parsePtr->numWords; if (numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"append varName ?value value ...?\"", + -1); return TCL_ERROR; } else if (numWords == 2) { /* - * append varName == set varName + * append varName === set varName */ - - return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); + return TclCompileSetCmd(interp, parsePtr, envPtr); } else if (numWords > 3) { /* - * APPEND instructions currently only handle one value. + * APPEND instructions currently only handle one value */ - - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* - * 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. */ - varTokenPtr = TokenAfter(parsePtr->tokenPtr); + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar, 1); + code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + if (code != TCL_OK) { + goto done; + } /* - * 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. + * 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. */ if (numWords > 2) { - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); + } else { + SetLineInformation (2); + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + } } /* @@ -288,27 +174,32 @@ TclCompileAppendCmd( if (simpleVarName) { if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); + } } else { - TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); + TclEmitOpcode(INST_APPEND_STK, envPtr); } } else { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); + } } else { - TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); + TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); } } } else { TclEmitOpcode(INST_APPEND_STK, envPtr); } - return TCL_OK; + done: + return code; } /* @@ -319,26 +210,28 @@ TclCompileAppendCmd( * Procedure called to compile the "break" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * 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( - 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. */ +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. */ { if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"break\"", -1); return TCL_ERROR; } @@ -358,239 +251,172 @@ TclCompileBreakCmd( * Procedure called to compile the "catch" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * 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( - 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. */ +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. */ { JumpFixup jumpFixup; - Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - const char *name; - int resultIndex, optsIndex, nameChars, range; - int initStackDepth = envPtr->currStackDepth; - int savedStackDepth; - DefineLineInformation; /* TIP #280 */ + Tcl_Token *cmdTokenPtr, *nameTokenPtr; + CONST char *name; + int localIndex, nameChars, range, startOffset, jumpDist; + int code; + int savedStackDepth = envPtr->currStackDepth; - /* - * If syntax does not match what we expect for [catch], do not compile. - * Let runtime checks determine if syntax has changed. - */ + DefineLineInformation; - if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"catch command ?varName?\"", -1); return TCL_ERROR; } /* - * 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 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 ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) { - return TCL_ERROR; + if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) { + return TCL_OUT_LINE_COMPILE; } /* - * Make sure the variable names, if any, have no substitutions and just - * refer to local scalars. + * Make sure the variable name, if any, has no substitutions and just + * refers to a local scaler. */ - resultIndex = optsIndex = -1; - cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords >= 3) { - resultNameTokenPtr = TokenAfter(cmdTokenPtr); - /* DGP */ - if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - name = resultNameTokenPtr[1].start; - nameChars = resultNameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start, - resultNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr); - if (resultIndex < 0) { - return TCL_ERROR; - } - - /* DKF */ - if (parsePtr->numWords == 4) { - optsNameTokenPtr = TokenAfter(resultNameTokenPtr); - if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = optsNameTokenPtr[1].start; - nameChars = optsNameTokenPtr[1].size; + 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_ERROR; - } - optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start, - optsNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr); - if (optsIndex < 0) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } + 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. Declare the exception range - * that it uses. + * We will compile the catch command. Emit a beginCatch instruction at + * the start of the catch body: the subcommand it controls. */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); /* - * 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. + * If the body is a simple word, compile the instructions to + * eval it. Otherwise, compile instructions to substitute its + * text without catching, a catch instruction that resets the + * stack to what it was before substituting the body, and then + * an instruction to eval the body. Care has to be taken to + * register the correct startOffset for the catch range so that + * errors in the substitution are not catched [Bug 219184] */ - SetLineInformation(1); + SetLineInformation (1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - savedStackDepth = envPtr->currStackDepth; - TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, cmdTokenPtr, interp); + startOffset = (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr); } else { - CompileTokens(envPtr, cmdTokenPtr, interp); - savedStackDepth = envPtr->currStackDepth; - TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - TclEmitOpcode(INST_DUP, envPtr); + code = TclCompileTokens(interp, cmdTokenPtr+1, + cmdTokenPtr->numComponents, envPtr); + startOffset = (envPtr->codeNext - envPtr->codeStart); TclEmitOpcode(INST_EVAL_STK, envPtr); } - /* Stack at this point: - * nonsimple: script <mark> result - * simple: <mark> result - */ - - /* - * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch - * result, and jump around the "error case" code. - */ - - PushLiteral(envPtr, "0", 1); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - /* Stack at this point: ?script? <mark> result TCL_OK */ - - /* - * Emit the "error case" epilogue. Push the interpreter result - * and the return code. - */ - - envPtr->currStackDepth = savedStackDepth; - ExceptionRangeTarget(envPtr, range, catchOffset); - /* Stack at this point: ?script? */ - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - - /* - * Update the target of the jump after the "no errors" code. - */ - - /* Stack at this point: ?script? result returnCode */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } - - /* Push the return options if the caller wants them */ + envPtr->exceptArrayPtr[range].codeOffset = startOffset; - if (optsIndex != -1) { - TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); + if (code != TCL_OK) { + code = TCL_OUT_LINE_COMPILE; + goto done; } - - /* - * End the catch - */ - - ExceptionRangeEnds(envPtr, range); - TclEmitOpcode(INST_END_CATCH, envPtr); - - /* - * At this point, the top of the stack is inconveniently ordered: - * ?script? result returnCode ?returnOptions? - * Reverse the stack to bring the result to the top. - */ - - if (optsIndex != -1) { - TclEmitInstInt4(INST_REVERSE, 3, envPtr); - } else { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - } - + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) - startOffset; + /* - * Store the result if requested, and remove it from the stack + * 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. */ - if (resultIndex != -1) { - if (resultIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); + if (localIndex != -1) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); } else { - TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); } } TclEmitOpcode(INST_POP, envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* - * Stack is now ?script? ?returnOptions? returnCode. - * If the options dict has been requested, it is buried on the stack - * under the return code. Reverse the stack to bring it to the top, - * store it and remove it from the stack. + * 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. */ - if (optsIndex != -1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - if (optsIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); + envPtr->currStackDepth = savedStackDepth; + 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, optsIndex, envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); } + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - /* - * Stack is now ?script? result. Get rid of the subst'ed script - * if it's hanging arond. - */ - - if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_POP, envPtr); - } /* - * Result of all this, on either branch, should have been to leave - * one operand -- the return code -- on the stack. + * Update the target of the jump after the "no errors" code, then emit + * an endCatch instruction at the end of the catch command. */ - if (envPtr->currStackDepth != initStackDepth + 1) { - Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", - envPtr->currStackDepth, initStackDepth+1); + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); } - return TCL_OK; + TclEmitOpcode(INST_END_CATCH, envPtr); + + done: + envPtr->currStackDepth = savedStackDepth + 1; + envPtr->exceptDepth--; + return code; } /* @@ -601,30 +427,32 @@ TclCompileCatchCmd( * Procedure called to compile the "continue" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * 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( - 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. */ +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. */ { /* * 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); return TCL_ERROR; } @@ -639,789 +467,45 @@ TclCompileContinueCmd( /* *---------------------------------------------------------------------- * - * 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. - * - * Notes: - * The following commands are in fairly common use and are possibly worth - * bytecoding: - * dict append - * dict create [*] - * dict exists [*] - * dict for - * dict get [*] - * dict incr - * dict keys [*] - * dict lappend - * dict set - * dict unset - * - * In practice, those that are pure-value operators (marked with [*]) can - * probably be left alone (except perhaps [dict get] which is very very - * common) and [dict update] should be considered instead (really big - * win!) - * - *---------------------------------------------------------------------- - */ - -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 numWords, i; - Proc *procPtr = envPtr->procPtr; - DefineLineInformation; /* TIP #280 */ - Tcl_Token *varTokenPtr; - int dictVarIndex, nameChars; - const char *name; - - /* - * There must be at least one argument after the command. - */ - - if (parsePtr->numWords < 4 || procPtr == NULL) { - 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); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - - /* - * Remaining words (key path and value to set) can be handled normally. - */ - - tokenPtr = TokenAfter(varTokenPtr); - numWords = parsePtr->numWords-1; - for (i=1 ; i<numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Now emit the instruction to do the dict manipulation. - */ - - TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); - TclEmitInt4( dictVarIndex, 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. */ -{ - Proc *procPtr = envPtr->procPtr; - DefineLineInformation; /* TIP #280 */ - Tcl_Token *varTokenPtr, *keyTokenPtr; - int dictVarIndex, nameChars, incrAmount; - const char *name; - - /* - * There must be at least two arguments after the command. - */ - - if (parsePtr->numWords < 3 || parsePtr->numWords > 4 || procPtr == NULL) { - 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 TCL_ERROR; - } - 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 TCL_ERROR; - } - } else { - incrAmount = 1; - } - - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - - /* - * Emit the key and the code to actually do the increment. - */ - - CompileWord(envPtr, keyTokenPtr, interp, 3); - 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 numWords, 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). - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; - - /* - * Only compile this because we need INST_DICT_GET anyway. - */ - - for (i=0 ; i<numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_DICT_GET, numWords-1, 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. */ -{ - Proc *procPtr = envPtr->procPtr; - DefineLineInformation; /* TIP #280 */ - Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; - int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - int numVars, endTargetOffset; - int savedStackDepth = envPtr->currStackDepth; - /* Needed because jumps confuse the stack - * space calculator. */ - const char **argv; - Tcl_DString buffer; - - /* - * There must be at least three argument after the command. - */ - - if (parsePtr->numWords != 4 || procPtr == NULL) { - return TCL_ERROR; - } - - varsTokenPtr = TokenAfter(parsePtr->tokenPtr); - dictTokenPtr = TokenAfter(varsTokenPtr); - bodyTokenPtr = TokenAfter(dictTokenPtr); - if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || - bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Check we've got a pair of variables and that they are local variables. - * Then extract their indices in the LVT. - */ - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, varsTokenPtr[1].start, varsTokenPtr[1].size); - if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars, - &argv) != TCL_OK) { - Tcl_DStringFree(&buffer); - return TCL_ERROR; - } - Tcl_DStringFree(&buffer); - if (numVars != 2) { - ckfree((char *) argv); - return TCL_ERROR; - } - - nameChars = strlen(argv[0]); - if (!TclIsLocalScalar(argv[0], nameChars)) { - ckfree((char *) argv); - return TCL_ERROR; - } - keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, procPtr); - - nameChars = strlen(argv[1]); - if (!TclIsLocalScalar(argv[1], nameChars)) { - ckfree((char *) argv); - return TCL_ERROR; - } - valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, procPtr); - ckfree((char *) argv); - - /* - * 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 = TclFindCompiledLocal(NULL, 0, 1, procPtr); - - /* - * Preparation complete; issue instructions. Note that this code issues - * fixed-sized jumps. That simplifies things a lot! - * - * First up, get the dictionary and start the iteration. No catching of - * errors at this point. - */ - - CompileWord(envPtr, dictTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); - - /* - * Now we catch errors from here on so that we can finalize the search - * started by Tcl_DictObjFirst above. - */ - - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); - ExceptionRangeStarts(envPtr, catchRange); - - /* - * Inside the iteration, write the loop variables. - */ - - bodyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Set up the loop exception targets. - */ - - loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - ExceptionRangeStarts(envPtr, loopRange); - - /* - * Compile the loop body itself. It should be stack-neutral. - */ - - SetLineInformation(3); - CompileBody(envPtr, bodyTokenPtr, interp); - 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); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Now do the final cleanup for the no-error case (this is where we break - * out of the loop to) by force-terminating the iteration (if not already - * terminated), ditching the exception info and jumping to the last - * instruction for this command. In theory, this could be done using the - * "finally" clause (next generated) but this is faster. - */ - - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP4, 0, envPtr); - - /* - * Error handler "finally" clause, which force-terminates the iteration - * and rethrows the error. - */ - - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); - - /* - * Otherwise we're done (the jump after the DICT_FIRST points here) and we - * need to pop the bogus key/value pair (pushed to keep stack calculations - * easy!) Note that we skip the END_CATCH. [Bug 1382528] - */ - - envPtr->currStackDepth = savedStackDepth+2; - jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, - envPtr->codeStart + emptyTargetOffset); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); - - /* - * Final stage of the command (normal case) is that we push an empty - * object. This is done last to promote peephole optimization when it's - * dropped immediately. - */ - - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, - envPtr->codeStart + endTargetOffset); - PushLiteral(envPtr, "", 0); - 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. */ -{ - Proc *procPtr = envPtr->procPtr; - DefineLineInformation; /* TIP #280 */ - const char *name; - int i, nameChars, 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 || procPtr == NULL) { - 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); - if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = dictVarTokenPtr[1].start; - nameChars = dictVarTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - - /* - * 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 = (DictUpdateInfo *) - ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); - duiPtr->length = numVars; - keyTokenPtrs = (Tcl_Token **) 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; - - /* - * Variables first need to be checked for sanity. - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - ckfree((char *) duiPtr); - TclStackFree(interp, keyTokenPtrs); - return TCL_ERROR; - } - name = tokenPtr[1].start; - nameChars = tokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - ckfree((char *) duiPtr); - TclStackFree(interp, keyTokenPtrs); - return TCL_ERROR; - } - - /* - * Stash the index in the auxiliary data. - */ - - duiPtr->varIndices[i] = - TclFindCompiledLocal(name, nameChars, 1, procPtr); - tokenPtr = TokenAfter(tokenPtr); - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - ckfree((char *) duiPtr); - TclStackFree(interp, keyTokenPtrs); - return TCL_ERROR; - } - 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, i); - } - TclEmitInstInt4( INST_LIST, numVars, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - - ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords - 1); - CompileBody(envPtr, bodyTokenPtr, interp); - 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); - TclEmitOpcode( INST_RETURN_STK, envPtr); - - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } - TclStackFree(interp, keyTokenPtrs); - return TCL_OK; -} - -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. */ -{ - Proc *procPtr = envPtr->procPtr; - 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. ;-) - */ - - if (parsePtr->numWords<4 || parsePtr->numWords>100 || procPtr==NULL) { - return TCL_ERROR; - } - - /* - * Get the index of the local variable that we will be working with. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } else { - register const char *name = tokenPtr[1].start; - register int nameChars = tokenPtr[1].size; - - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - } - - /* - * 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_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. */ -{ - Proc *procPtr = envPtr->procPtr; - DefineLineInformation; /* TIP #280 */ - Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; - int dictVarIndex, nameChars; - const char *name; - - /* - * There must be three arguments after the command. - */ - - if (parsePtr->numWords != 4 || procPtr == NULL) { - return TCL_ERROR; - } - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - keyTokenPtr = TokenAfter(varTokenPtr); - valueTokenPtr = TokenAfter(keyTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - CompileWord(envPtr, keyTokenPtr, interp, 3); - CompileWord(envPtr, valueTokenPtr, interp, 4); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); - 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 = (DictUpdateInfo *) 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]); - } -} - -/* - *---------------------------------------------------------------------- - * * TclCompileExprCmd -- * * Procedure called to compile the "expr" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * 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( - 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. */ +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. */ { Tcl_Token *firstWordPtr; + DefineLineInformation; + if (parsePtr->numWords == 1) { - return TCL_ERROR; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"expr arg ?arg ...?\"", -1); + return TCL_ERROR; } - /* - * 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; + SetLineInformation (1); + firstWordPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), + envPtr); } /* @@ -1432,33 +516,36 @@ TclCompileExprCmd( * Procedure called to compile the "for" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * 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( - 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. */ +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. */ { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; - int bodyRange, nextRange; + int bodyRange, nextRange, code; + char buffer[32 + TCL_INTEGER_SPACE]; int savedStackDepth = envPtr->currStackDepth; - DefineLineInformation; /* TIP #280 */ + + DefineLineInformation; 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; } @@ -1468,10 +555,11 @@ TclCompileForCmd( * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". */ - startTokenPtr = TokenAfter(parsePtr->tokenPtr); - testTokenPtr = TokenAfter(startTokenPtr); + startTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1); if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* @@ -1479,20 +567,23 @@ TclCompileForCmd( * in order to insure correct behaviour [Bug 219166] */ - nextTokenPtr = TokenAfter(testTokenPtr); - bodyTokenPtr = TokenAfter(nextTokenPtr); - if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); + if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* - * 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). + * Create ExceptionRange records for the body and the "next" command. + * The "next" command's ExceptionRange supports break but not continue + * (and has a -1 continueOffset). */ - bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* @@ -1500,9 +591,17 @@ TclCompileForCmd( */ SetLineInformation (1); - CompileBody(envPtr, startTokenPtr, interp); + 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; + } TclEmitOpcode(INST_POP, envPtr); - + /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). @@ -1521,23 +620,46 @@ TclCompileForCmd( * Compile the loop body. */ - bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); + bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); + SetLineInformation (4); - CompileBody(envPtr, bodyTokenPtr, interp); - ExceptionRangeEnds(envPtr, bodyRange); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"for\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + envPtr->exceptArrayPtr[bodyRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); + /* * Compile the "next" subcommand. */ - envPtr->currStackDepth = savedStackDepth; - nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); + nextCodeOffset = (envPtr->codeNext - envPtr->codeStart); + SetLineInformation (3); - CompileBody(envPtr, nextTokenPtr, interp); - ExceptionRangeEnds(envPtr, nextRange); + envPtr->currStackDepth = savedStackDepth; + code = TclCompileCmdWord(interp, nextTokenPtr+1, + nextTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" loop-end command)", -1); + } + goto done; + } + envPtr->exceptArrayPtr[nextRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - nextCodeOffset; TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth; @@ -1546,7 +668,7 @@ TclCompileForCmd( * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { @@ -1554,22 +676,27 @@ TclCompileForCmd( nextCodeOffset += 3; testCodeOffset += 3; } - SetLineInformation (2); envPtr->currStackDepth = savedStackDepth; - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" test expression)", -1); + } + goto done; + } envPtr->currStackDepth = savedStackDepth + 1; - - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; + + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } - + /* - * Fix the starting points of the exception ranges (may have moved due to - * jump type modification) and set where the exceptions target. + * Set the loop's offsets and break target. */ envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; @@ -1577,17 +704,21 @@ TclCompileForCmd( envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; - ExceptionRangeTarget(envPtr, bodyRange, breakOffset); - ExceptionRangeTarget(envPtr, nextRange, breakOffset); - + envPtr->exceptArrayPtr[bodyRange].breakOffset = + envPtr->exceptArrayPtr[nextRange].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + /* * The for command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + code = TCL_OK; - return TCL_OK; + done: + envPtr->exceptDepth--; + return code; } /* @@ -1598,24 +729,27 @@ TclCompileForCmd( * Procedure called to compile the "foreach" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * Side effects: - * Instructions are added to envPtr to execute the "foreach" command at - * runtime. + * Instructions are added to envPtr to execute the "foreach" command + * at runtime. * - *---------------------------------------------------------------------- +n*---------------------------------------------------------------------- */ 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. */ +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. */ { Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr; /* Points to the structure describing this @@ -1628,19 +762,28 @@ TclCompileForeachCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; + int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; + char buffer[32 + TCL_INTEGER_SPACE]; int savedStackDepth = envPtr->currStackDepth; - DefineLineInformation; /* TIP #280 */ + +#ifdef TCL_TIP280 + int bodyIndex; +#endif /* * 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 */ - int *varcList; - const char ***varvList; +#define STATIC_VAR_LIST_SIZE 5 + int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; + CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; + int *varcList = varcListStaticSpace; + CONST char ***varvList = varvListStaticSpace; + + DefineLineInformation; /* * If the foreach command isn't in a procedure, don't compile it inline: @@ -1648,120 +791,129 @@ TclCompileForeachCmd( */ if (procPtr == NULL) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { - return TCL_ERROR; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); + return TCL_ERROR; } /* - * Bail out if the body requires substitutions in order to insure correct - * behaviour. [Bug 219166] + * Bail out if the body requires substitutions + * in order to insure correct behaviour [Bug 219166] */ - - for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) { - tokenPtr = TokenAfter(tokenPtr); + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { } bodyTokenPtr = tokenPtr; if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } - +#ifdef TCL_TIP280 bodyIndex = i-1; +#endif /* * Allocate storage for the varcList and varvList arrays if necessary. */ numLists = (numWords - 2)/2; - varcList = (int *) 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 **)); + if (numLists > STATIC_VAR_LIST_SIZE) { + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **)); + } + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + varcList[loopIndex] = 0; + varvList[loopIndex] = NULL; + } + + /* + * Set the exception stack depth. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); /* - * 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 = TokenAfter(tokenPtr)) { - Tcl_DString varList; - - if (i%2 != 1) { - continue; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - code = TCL_ERROR; - goto done; - } - - /* - * Lots of copying going on here. Need a ListObj wizard to show a - * better way. - */ - - Tcl_DStringInit(&varList); - Tcl_DStringAppend(&varList, tokenPtr[1].start, tokenPtr[1].size); - code = Tcl_SplitList(interp, 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] - */ + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (i%2 == 1) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } else { + /* Lots of copying going on here. Need a ListObj wizard + * to show a better way. */ + + Tcl_DString varList; + + Tcl_DStringInit(&varList); + Tcl_DStringAppend(&varList, tokenPtr[1].start, + tokenPtr[1].size); + code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + &varcList[loopIndex], &varvList[loopIndex]); + Tcl_DStringFree(&varList); + if (code != TCL_OK) { + goto done; + } + numVars = varcList[loopIndex]; - if (numVars == 0) { - code = TCL_ERROR; - goto done; - } + /* + * 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] + */ - for (j = 0; j < numVars; j++) { - const char *varName = varvList[loopIndex][j]; + if (numVars == 0) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } - if (!TclIsLocalScalar(varName, (int) strlen(varName))) { - 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_OUT_LINE_COMPILE; + goto done; + } + } } + loopIndex++; } - loopIndex++; } /* - * We will compile the foreach command. Reserve (numLists + 1) temporary - * variables: + * 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. */ - code = TCL_OK; firstValueTemp = -1; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, procPtr); + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); if (loopIndex == 0) { firstValueTemp = tempVar; } } loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, procPtr); - + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + /* * Create and initialize the ForeachInfo and ForeachVarList data * structures describing this command. Then create a AuxData record @@ -1769,7 +921,7 @@ TclCompileForeachCmd( */ infoPtr = (ForeachInfo *) ckalloc((unsigned) - sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; @@ -1777,36 +929,36 @@ TclCompileForeachCmd( ForeachVarList *varListPtr; numVars = varcList[loopIndex]; varListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); + sizeof(ForeachVarList) + (numVars * sizeof(int))); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { - const char *varName = varvList[loopIndex][j]; + CONST char *varName = varvList[loopIndex][j]; int nameChars = strlen(varName); - varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, - nameChars, /*create*/ 1, procPtr); + nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); } infoPtr->varLists[loopIndex] = varListPtr; } - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); - - /* - * Create an exception record to handle [break] and [continue]. - */ - - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); /* * Evaluate then store each value list in the associated temporary. */ + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; - i++, tokenPtr = TokenAfter(tokenPtr)) { + i++, tokenPtr += (tokenPtr->numComponents + 1)) { if ((i%2 == 0) && (i > 0)) { SetLineInformation (i); - CompileTokens(envPtr, tokenPtr, interp); + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); @@ -1823,36 +975,50 @@ TclCompileForeachCmd( */ TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - + /* * Top of loop code: assign each loop variable and check whether * to terminate the loop. */ - ExceptionRangeTarget(envPtr, range, continueOffset); + envPtr->exceptArrayPtr[range].continueOffset = + (envPtr->codeNext - envPtr->codeStart); TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - + /* * Inline compile the loop body. */ SetLineInformation (bodyIndex); - ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); - ExceptionRangeEnds(envPtr, range); + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + 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 + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and * ensures that we won't have to replace this jump if we later need to * replace the ifFalse jump with a 4 byte jump. */ - jumpBackOffset = CurrentOffset(envPtr); - jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = + (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset); if (jumpBackDist > 120) { TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); } else { @@ -1863,7 +1029,9 @@ TclCompileForeachCmd( * Fix the target of the jump after the foreach_step test. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { + 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. */ @@ -1889,24 +1057,28 @@ TclCompileForeachCmd( * Set the loop's break target. */ - ExceptionRangeTarget(envPtr, range, breakOffset); - + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + /* * The foreach command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); envPtr->currStackDepth = savedStackDepth + 1; - done: + done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - if (varvList[loopIndex] != NULL) { + if (varvList[loopIndex] != (CONST char **) NULL) { ckfree((char *) varvList[loopIndex]); } } - TclStackFree(interp, (void *)varvList); - TclStackFree(interp, varcList); + if (varcList != varcListStaticSpace) { + ckfree((char *) varcList); + ckfree((char *) varvList); + } + envPtr->exceptDepth--; return code; } @@ -1915,8 +1087,8 @@ TclCompileForeachCmd( * * 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 @@ -1924,41 +1096,42 @@ TclCompileForeachCmd( * * 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) /* The foreach command's compilation auxiliary - * data to duplicate. */ +DupForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to duplicate. */ { - register ForeachInfo *srcPtr = clientData; + register ForeachInfo *srcPtr = (ForeachInfo *) clientData; ForeachInfo *dupPtr; register ForeachVarList *srcListPtr, *dupListPtr; - int numVars, i, j, numLists = srcPtr->numLists; - + int numLists = srcPtr->numLists; + int numVars, i, j; + dupPtr = (ForeachInfo *) ckalloc((unsigned) - sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); + (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)); + 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 dupPtr; + return (ClientData) dupPtr; } /* @@ -1981,11 +1154,11 @@ DupForeachInfo( */ static void -FreeForeachInfo( - ClientData clientData) /* The foreach command's compilation auxiliary - * data to free. */ +FreeForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to free. */ { - register ForeachInfo *infoPtr = clientData; + register ForeachInfo *infoPtr = (ForeachInfo *) clientData; register ForeachVarList *listPtr; int numLists = infoPtr->numLists; register int i; @@ -2000,111 +1173,58 @@ FreeForeachInfo( /* *---------------------------------------------------------------------- * - * PrintForeachInfo -- - * - * Function to write a human-readable representation of a ForeachInfo - * structure to stdout for debugging. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PrintForeachInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; - int i, j; - - Tcl_AppendToObj(appendObj, "data=[", -1); - - for (i=0 ; i<infoPtr->numLists ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ", ", -1); - } - 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); - } - 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); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); - } - Tcl_AppendToObj(appendObj, "]", -1); - } -} - -/* - *---------------------------------------------------------------------- - * * TclCompileIfCmd -- * * Procedure called to compile the "if" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * Side effects: - * Instructions are added to envPtr to execute the "if" command at - * runtime. + * Instructions are added to envPtr to execute the "if" command + * at runtime. * *---------------------------------------------------------------------- */ - int -TclCompileIfCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +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. */ { 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. */ + /* Used to fix the jump after each "then" + * body to the end of the "if" when that PC + * is determined. */ Tcl_Token *tokenPtr, *testTokenPtr; - int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; - const char *word; + int jumpDist, jumpFalseDist; + int jumpIndex = 0; /* avoid compiler warning. */ + int numWords, wordIdx, numBytes, j, code; + CONST char *word; + char buffer[100]; int savedStackDepth = envPtr->currStackDepth; - /* Saved stack depth at the start of the first + /* Saved stack depth at the start of the first * test; the envPtr current depth is restored * to this value at the start of each test. */ - int realCond = 1; /* Set to 0 for static conditions: - * "if 0 {..}" */ - int boolVal; /* Value of static condition. */ - int compileScripts = 1; - DefineLineInformation; /* TIP #280 */ + int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */ + int boolVal; /* value of static condition */ + int compileScripts = 1; + + DefineLineInformation; /* - * Only compile the "if" command if all arguments are simple words, in - * order to insure correct substitution [Bug 219166] + * Only compile the "if" command if all arguments are simple + * words, in order to insure correct substitution [Bug 219166] */ tokenPtr = parsePtr->tokenPtr; @@ -2113,18 +1233,19 @@ TclCompileIfCmd( for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } - tokenPtr = TokenAfter(tokenPtr); + tokenPtr += 2; } + TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); code = TCL_OK; /* - * Each iteration of this loop compiles one "if expr ?then? body" or - * "elseif expr ?then? body" clause. + * Each iteration of this loop compiles one "if expr ?then? body" + * or "elseif expr ?then? body" clause. */ tokenPtr = parsePtr->tokenPtr; @@ -2137,66 +1258,84 @@ TclCompileIfCmd( word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { - tokenPtr = TokenAfter(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 \"%.*s\" argument", + (numBytes > 50 ? 50 : numBytes), word); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); code = TCL_ERROR; goto done; } /* - * Compile the test expression then emit the conditional jump around - * the "then" part. + * Compile the test expression then emit the conditional jump + * around the "then" part. */ - + envPtr->currStackDepth = savedStackDepth; testTokenPtr = tokenPtr; + if (realCond) { /* - * Find out if the condition is a constant. + * Find out if the condition is a constant. */ - + Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); Tcl_IncrRefCount(boolObj); code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); + Tcl_DecrRefCount(boolObj); if (code == TCL_OK) { /* - * A static condition. + * A static condition */ - realCond = 0; if (!boolVal) { compileScripts = 0; } } else { - SetLineInformation (wordIdx); Tcl_ResetResult(interp); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + SetLineInformation (wordIdx); + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"if\" test expression)", -1); + } + goto done; + } if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); + &(jumpFalseFixupArray.fixup[jumpIndex])); } - code = TCL_OK; } + /* * Skip over the optional "then" before the then clause. */ - tokenPtr = TokenAfter(testTokenPtr); + tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); wordIdx++; if (wordIdx >= numWords) { + sprintf(buffer, + "wrong # args: no script following \"%.*s\" argument", + (testTokenPtr->size > 50 ? 50 : testTokenPtr->size), + testTokenPtr->start); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); code = TCL_ERROR; goto done; } @@ -2204,9 +1343,12 @@ TclCompileIfCmd( word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); + 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; } @@ -2220,72 +1362,85 @@ TclCompileIfCmd( if (compileScripts) { SetLineInformation (wordIdx); envPtr->currStackDepth = savedStackDepth; - CompileBody(envPtr, tokenPtr, interp); + 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; + } } if (realCond) { /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray - * and jumpEndFixupArray are indexed by "jumpIndex". + * Jump to the end of the "if" command. Both jumpFalseFixupArray and + * jumpEndFixupArray are indexed by "jumpIndex". */ - + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { TclExpandJumpFixupArray(&jumpEndFixupArray); } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); - + &(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. + * Fix the target of the jumpFalse after the test. Generate a 4 byte + * jump if the distance is > 120 bytes. This is conservative, and + * ensures that we won't have to replace this jump if we later also + * need to replace the proceeding jump to the end of the "if" with a + * 4 byte jump. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { + 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. */ - + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; } } else if (boolVal) { - /* - * We were processing an "if 1 {...}"; stop compiling scripts. + /* + *We were processing an "if 1 {...}"; stop compiling + * scripts */ compileScripts = 0; } else { - /* - * We were processing an "if 0 {...}"; reset so that the rest - * (elseif, else) is compiled correctly. + /* + *We were processing an "if 0 {...}"; reset so that + * the rest (elseif, else) is compiled correctly */ realCond = 1; compileScripts = 1; - } + } - tokenPtr = TokenAfter(tokenPtr); + tokenPtr += (tokenPtr->numComponents + 1); wordIdx++; } /* - * Restore the current stack depth in the environment; the "else" clause - * (or its default) will add 1 to this. + * Restore the current stack depth in the environment; the + * "else" clause (or its default) will add 1 to this. */ envPtr->currStackDepth = savedStackDepth; /* - * Check for the optional else clause. Do not compile anything if this was - * an "if 1 {...}" case. + * Check for the optional else clause. Do not compile + * anything if this was an "if 1 {...}" case. */ - if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + if ((wordIdx < numWords) + && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { /* * There is an else clause. Skip over the optional "else" word. */ @@ -2293,9 +1448,12 @@ TclCompileIfCmd( word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); + 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; } @@ -2305,17 +1463,28 @@ TclCompileIfCmd( /* * Compile the else command body. */ - SetLineInformation (wordIdx); - CompileBody(envPtr, tokenPtr, interp); + 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; + } } /* * 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; } @@ -2325,27 +1494,28 @@ TclCompileIfCmd( */ if (compileScripts) { - PushLiteral(envPtr, "", 0); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } } /* * Fix the unconditional jumps to the end of the "if" command. */ - + for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { + 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. + * 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; + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; unsigned char opCode = *ifFalsePc; - if (opCode == INST_JUMP_FALSE1) { jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); jumpFalseDist += 3; @@ -2355,7 +1525,7 @@ TclCompileIfCmd( jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); } } } @@ -2364,7 +1534,7 @@ TclCompileIfCmd( * Free the jumpFixupArray array if malloc'ed storage was used. */ - done: + done: envPtr->currStackDepth = savedStackDepth + 1; TclFreeJumpFixupArray(&jumpFalseFixupArray); TclFreeJumpFixupArray(&jumpEndFixupArray); @@ -2379,37 +1549,50 @@ TclCompileIfCmd( * Procedure called to compile the "incr" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * Side effects: - * Instructions are added to envPtr to execute the "incr" command at - * runtime. + * Instructions are added to envPtr to execute the "incr" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileIncrCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +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; int simpleVarName, isScalar, localIndex, haveImmValue, immValue; - DefineLineInformation; /* TIP #280 */ + int code = TCL_OK; + + DefineLineInformation; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"incr varName ?increment?\"", -1); return TCL_ERROR; } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar, 1); + code = TclPushVarNameWord(interp, varTokenPtr, envPtr, + (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR), + &localIndex, &simpleVarName, &isScalar, 1); + if (code != TCL_OK) { + goto done; + } /* * If an increment is given, push it, but see first if it's a small @@ -2419,29 +1602,44 @@ TclCompileIncrCmd( haveImmValue = 0; immValue = 1; if (parsePtr->numWords == 3) { - incrTokenPtr = TokenAfter(varTokenPtr); + incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *word = incrTokenPtr[1].start; + CONST char *word = incrTokenPtr[1].start; int numBytes = incrTokenPtr[1].size; - int code; - Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &immValue); - TclDecrRefCount(intObj); - if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { - haveImmValue = 1; + + /* + * Note there is a danger that modifying the string could have + * undesirable side effects. In this case, TclLooksLikeInt has + * no dependencies on shared strings so we should be safe. + */ + + if (TclLooksLikeInt(word, numBytes)) { + int code; + Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); + Tcl_IncrRefCount(intObj); + code = Tcl_GetIntFromObj(NULL, intObj, &immValue); + Tcl_DecrRefCount(intObj); + if ((code == TCL_OK) + && (-127 <= immValue) && (immValue <= 127)) { + haveImmValue = 1; + } } if (!haveImmValue) { - PushLiteral(envPtr, word, numBytes); + TclEmitPush( + TclRegisterNewLiteral(envPtr, word, numBytes), envPtr); } } else { SetLineInformation (2); - CompileTokens(envPtr, incrTokenPtr, interp); + code = TclCompileTokens(interp, incrTokenPtr+1, + incrTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } } - } else { /* No incr amount given so use 1. */ + } else { /* no incr amount given so use 1 */ haveImmValue = 1; } - + /* * Emit the instruction to increment the variable. */ @@ -2478,15 +1676,16 @@ TclCompileIncrCmd( } } } - } else { /* Non-simple variable name. */ + } else { /* non-simple variable name */ if (haveImmValue) { TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_STK, envPtr); } } - - return TCL_OK; + + done: + return code; } /* @@ -2497,47 +1696,53 @@ TclCompileIncrCmd( * Procedure called to compile the "lappend" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 + * compilation fails because the command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_LappendObjCmd) at runtime. * * Side effects: - * Instructions are added to envPtr to execute the "lappend" command at - * runtime. + * Instructions are added to envPtr to execute the "lappend" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileLappendCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +TclCompileLappendCmd(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; + Tcl_Token *varTokenPtr, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; - DefineLineInformation; /* TIP #280 */ + int code = TCL_OK; + + DefineLineInformation; /* * If we're not in a procedure, don't compile. */ - if (envPtr->procPtr == NULL) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } numWords = parsePtr->numWords; if (numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"lappend varName ?value value ...?\"", -1); return TCL_ERROR; } if (numWords != 3) { /* - * LAPPEND instructions currently only handle one value appends. + * LAPPEND instructions currently only handle one value appends */ - - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* @@ -2545,22 +1750,36 @@ TclCompileLappendCmd( * 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. + * namespace qualifiers. */ - varTokenPtr = TokenAfter(parsePtr->tokenPtr); + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar, 1); + code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + if (code != TCL_OK) { + goto done; + } /* - * If we are doing an assignment, push the new value. In the no values - * case, create an empty object. + * If we are doing an assignment, push the new value. + * In the no values case, create an empty object. */ if (numWords > 2) { - Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); + } else { + SetLineInformation (2); + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + } } /* @@ -2571,239 +1790,112 @@ TclCompileLappendCmd( * The *_STK opcodes should be refactored to make better use of existing * LOAD/STORE instructions. */ - if (simpleVarName) { if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_LAPPEND_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); + } } else { - TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); + TclEmitOpcode(INST_LAPPEND_STK, envPtr); } } else { - if (localIndex < 0) { - TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); + } } else { - TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); + TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); } } } else { TclEmitOpcode(INST_LAPPEND_STK, envPtr); } - return TCL_OK; + done: + return code; } /* *---------------------------------------------------------------------- * - * TclCompileLassignCmd -- + * TclCompileLindexCmd -- * - * Procedure called to compile the "lassign" command. + * Procedure called to compile the "lindex" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. * * Side effects: - * Instructions are added to envPtr to execute the "lassign" command at - * runtime. + * Instructions are added to envPtr to execute the "lindex" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileLassignCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +TclCompileLindexCmd(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 *tokenPtr; - int simpleVarName, isScalar, localIndex, numWords, idx; - DefineLineInformation; /* TIP #280 */ + Tcl_Token *varTokenPtr; + int code, i; + int numWords; + + DefineLineInformation; numWords = parsePtr->numWords; /* - * Check for command syntax error, but we'll punt that to runtime. + * Quit if too few args */ - if (numWords < 3) { - return TCL_ERROR; + if ( numWords <= 1 ) { + return TCL_OUT_LINE_COMPILE; } + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + /* - * Generate code to push list being taken apart by [lassign]. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Generate code to assign values from the list to variables. + * Push the operands onto the stack. */ - - for (idx=0 ; idx<numWords-2 ; idx++) { - tokenPtr = TokenAfter(tokenPtr); - - /* - * Generate the next variable name. - */ - - PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, - &simpleVarName, &isScalar, idx+2); - - /* - * Emit instructions to get the idx'th item out of the list value on - * the stack and assign it to the variable. - */ - - if (simpleVarName) { - if (isScalar) { - if (localIndex >= 0) { - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr); - } - } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); - } - } else { - if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - if (localIndex <= 255) { - TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); - } - } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); - } - } + + for ( i = 1 ; i < numWords ; i++ ) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush( + TclRegisterNewLiteral( envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode(INST_STORE_STK, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - - /* - * Generate code to leave the rest of the list on the stack. - */ - - TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4(-2, envPtr); /* -2 == "end" */ - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLindexCmd -- - * - * Procedure called to compile the "lindex" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lindex" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLindexCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, numWords = parsePtr->numWords; - DefineLineInformation; /* TIP #280 */ - - /* - * Quit if too few args. - */ - - if (numWords <= 1) { - return TCL_ERROR; - } - - valTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (numWords != 3) { - goto emitComplexLindex; - } - - idxTokenPtr = TokenAfter(valTokenPtr); - if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_Obj *tmpObj; - int idx, result; - - tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx); - TclDecrRefCount(tmpObj); - - if (result == TCL_OK && idx >= 0) { - /* - * All checks have been completed, and we have exactly this - * construct: - * lindex <arbitraryValue> <posInt> - * This is best compiled as a push of the arbitrary value followed - * by an "immediate lindex" which is the most efficient variety. - */ - - CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - return TCL_OK; + SetLineInformation (i); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } } - - /* - * If the conversion failed or the value was negative, we just keep on - * going with the more complex compilation. - */ - } - - /* - * Push the operands onto the stack. - */ - - emitComplexLindex: - for (i=1 ; i<numWords ; i++) { - CompileWord(envPtr, valTokenPtr, interp, i); - valTokenPtr = TokenAfter(valTokenPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } - + /* - * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are - * multiple index args. + * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI + * if there are multiple index args. */ - if (numWords == 3) { - TclEmitOpcode(INST_LIST_INDEX, envPtr); + if ( numWords == 3 ) { + TclEmitOpcode( INST_LIST_INDEX, envPtr ); } else { - TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr); + TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr ); } return TCL_OK; @@ -2817,55 +1909,67 @@ TclCompileLindexCmd( * Procedure called to compile the "list" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 + * compilation fails because the command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_ListObjCmd) at runtime. * * Side effects: - * Instructions are added to envPtr to execute the "list" command at - * runtime. + * Instructions are added to envPtr to execute the "list" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileListCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +TclCompileListCmd(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. */ { - DefineLineInformation; /* TIP #280 */ + DefineLineInformation; /* * If we're not in a procedure, don't compile. */ - if (envPtr->procPtr == NULL) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } if (parsePtr->numWords == 1) { /* - * [list] without arguments just pushes an empty object. + * Empty args case */ - PushLiteral(envPtr, "", 0); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } else { /* * Push the all values onto the stack. */ - Tcl_Token *valueTokenPtr; - int i, numWords; + int i, code, numWords; numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + valueTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); for (i = 1; i < numWords; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); + } else { + SetLineInformation (i); + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1); } TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); } @@ -2881,34 +1985,54 @@ TclCompileListCmd( * Procedure called to compile the "llength" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. * * Side effects: - * Instructions are added to envPtr to execute the "llength" command at - * runtime. + * Instructions are added to envPtr to execute the "llength" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileLlengthCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +TclCompileLlengthCmd(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; - DefineLineInformation; /* TIP #280 */ + int code; + + DefineLineInformation; if (parsePtr->numWords != 2) { + Tcl_SetResult(interp, "wrong # args: should be \"llength list\"", + TCL_STATIC); return TCL_ERROR; } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); - CompileWord(envPtr, varTokenPtr, interp, 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * We could simply count the number of elements here and push + * that value, but that is too rare a case to waste the code space. + */ + TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); + } else { + SetLineInformation (1); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } TclEmitOpcode(INST_LIST_LENGTH, envPtr); return TCL_OK; } @@ -2921,175 +2045,197 @@ TclCompileLlengthCmd( * Procedure called to compile the "lset" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The return value is a standard Tcl result, which is TCL_OK if + * the compilation was successful. If the "lset" command is too + * complex for this function, then TCL_OUT_LINE_COMPILE is returned, + * indicating that the command should be compiled "out of line" + * (that is, not byte-compiled). If an error occurs, TCL_ERROR is + * returned, and the interpreter result contains an error message. * * Side effects: - * Instructions are added to envPtr to execute the "lset" command at - * runtime. + * Instructions are added to envPtr to execute the "lset" command + * at runtime. * * The general template for execution of the "lset" command is: - * (1) Instructions to push the variable name, unless the variable is - * local to the stack frame. - * (2) If the variable is an array element, instructions to push the - * array element name. - * (3) Instructions to push each of zero or more "index" arguments to the - * stack, followed with the "newValue" element. - * (4) Instructions to duplicate the variable name and/or array element - * name onto the top of the stack, if either was pushed at steps (1) - * and (2). - * (5) The appropriate INST_LOAD_* instruction to place the original - * value of the list variable at top of stack. + * (1) Instructions to push the variable name, unless the + * variable is local to the stack frame. + * (2) If the variable is an array element, instructions + * to push the array element name. + * (3) Instructions to push each of zero or more "index" arguments + * to the stack, followed with the "newValue" element. + * (4) Instructions to duplicate the variable name and/or array + * element name onto the top of the stack, if either was + * pushed at steps (1) and (2). + * (5) The appropriate INST_LOAD_* instruction to place the + * original value of the list variable at top of stack. * (6) At this point, the stack contains: - * varName? arrayElementName? index1 index2 ... newValue oldList + * varName? arrayElementName? index1 index2 ... newValue oldList * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST - * according as whether there is exactly one index element (LIST) or - * either zero or else two or more (FLAT). This instruction removes - * everything from the stack except for the two names and pushes the - * new value of the variable. - * (7) Finally, INST_STORE_* stores the new value in the variable and - * cleans up the stack. + * according as whether there is exactly one index element (LIST) + * or either zero or else two or more (FLAT). This instruction + * removes everything from the stack except for the two names + * and pushes the new value of the variable. + * (7) Finally, INST_STORE_* stores the new value in the variable + * and cleans up the stack. * *---------------------------------------------------------------------- */ int -TclCompileLsetCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ +TclCompileLsetCmd( interp, parsePtr, envPtr ) + Tcl_Interp* interp; /* Tcl interpreter for error reporting */ + Tcl_Parse* parsePtr; /* Points to a parse structure for + * the command */ + CompileEnv* envPtr; /* Holds the resulting instructions */ { - int tempDepth; /* Depth used for emitting one part of the - * code burst. */ - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the variable name. */ - int localIndex; /* Index of var in local var table. */ - int simpleVarName; /* Flag == 1 if var name is simple. */ - int isScalar; /* Flag == 1 if scalar, 0 if array. */ + + int tempDepth; /* Depth used for emitting one part + * of the code burst. */ + Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing + * the parse of the variable name */ + + int result; /* Status return from library calls */ + + int localIndex; /* Index of var in local var table */ + int simpleVarName; /* Flag == 1 if var name is simple */ + int isScalar; /* Flag == 1 if scalar, 0 if array */ + int i; - DefineLineInformation; /* TIP #280 */ - /* - * Check argument count. - */ + DefineLineInformation; - if (parsePtr->numWords < 3) { - /* - * Fail at run time, not in compilation. - */ + /* Check argument count */ - return TCL_ERROR; + if ( parsePtr->numWords < 3 ) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; } /* - * 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. */ - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar, 1); + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + result = TclPushVarNameWord( interp, varTokenPtr, envPtr, + TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); + if (result != TCL_OK) { + return result; + } - /* - * Push the "index" args and the new element value. - */ + /* Push the "index" args and the new element value. */ + + for ( i = 2; i < parsePtr->numWords; ++i ) { + + /* Advance to next arg */ - for (i=2 ; i<parsePtr->numWords ; ++i) { - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, i); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + + /* Push an arg */ + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); + } else { + SetLineInformation (i); + result = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if ( result != TCL_OK ) { + return result; + } + } } /* - * Duplicate the variable name if it's been pushed. + * Duplicate the variable name if it's been pushed. */ - if (!simpleVarName || localIndex < 0) { - if (!simpleVarName || isScalar) { + if ( !simpleVarName || localIndex < 0 ) { + if ( !simpleVarName || isScalar ) { tempDepth = parsePtr->numWords - 2; } else { tempDepth = parsePtr->numWords - 1; } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + TclEmitInstInt4( INST_OVER, tempDepth, envPtr ); } /* - * Duplicate an array index if one's been pushed. + * Duplicate an array index if one's been pushed */ - if (simpleVarName && !isScalar) { - if (localIndex < 0) { + if ( simpleVarName && !isScalar ) { + if ( localIndex < 0 ) { tempDepth = parsePtr->numWords - 1; } else { tempDepth = parsePtr->numWords - 2; } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + TclEmitInstInt4( INST_OVER, tempDepth, envPtr ); } /* * Emit code to load the variable's value. */ - if (!simpleVarName) { - TclEmitOpcode(INST_LOAD_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr); + if ( !simpleVarName ) { + TclEmitOpcode( INST_LOAD_STK, envPtr ); + } else if ( isScalar ) { + if ( localIndex < 0 ) { + TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr ); } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr ); } } else { - if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr); + if ( localIndex < 0 ) { + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr ); } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr); + TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr ); } } /* - * Emit the correct variety of 'lset' instruction. + * Emit the correct variety of 'lset' instruction */ - if (parsePtr->numWords == 4) { - TclEmitOpcode(INST_LSET_LIST, envPtr); + if ( parsePtr->numWords == 4 ) { + TclEmitOpcode( INST_LSET_LIST, envPtr ); } else { - TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr ); } /* - * Emit code to put the value back in the variable. + * Emit code to put the value back in the variable */ - if (!simpleVarName) { - TclEmitOpcode(INST_STORE_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + if ( !simpleVarName ) { + TclEmitOpcode( INST_STORE_STK, envPtr ); + } else if ( isScalar ) { + if ( localIndex < 0 ) { + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr ); } else { - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr ); } } else { - if (localIndex < 0) { - TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); - } else if (localIndex < 0x100) { - TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + if ( localIndex < 0 ) { + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr ); } else { - TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr ); } } - + return TCL_OK; + } /* @@ -3100,155 +2246,193 @@ TclCompileLsetCmd( * Procedure called to compile the "regexp" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The return value is a standard Tcl result, which is TCL_OK if + * the compilation was successful. If the "regexp" command is too + * complex for this function, then TCL_OUT_LINE_COMPILE is returned, + * indicating that the command should be compiled "out of line" + * (that is, not byte-compiled). If an error occurs, TCL_ERROR is + * returned, and the interpreter result contains an error message. * * Side effects: - * Instructions are added to envPtr to execute the "regexp" command at - * runtime. + * Instructions are added to envPtr to execute the "regexp" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileRegexpCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the RE or string. */ - int i, len, nocase, exact, sawLast, simple; +TclCompileRegexpCmd(interp, parsePtr, envPtr) + Tcl_Interp* interp; /* Tcl interpreter for error reporting */ + Tcl_Parse* parsePtr; /* Points to a parse structure for + * the command */ + CompileEnv* envPtr; /* Holds the resulting instructions */ +{ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing + * the parse of the RE or string */ + int i, len, code, nocase, anchorLeft, anchorRight, start; char *str; - DefineLineInformation; /* TIP #280 */ + + DefineLineInformation; /* - * We are only interested in compiling simple regexp cases. Currently - * supported compile cases are: + * We are only interested in compiling simple regexp cases. + * Currently supported compile cases are: * regexp ?-nocase? ?--? staticString $var * regexp ?-nocase? ?--? {^staticString$} $var */ - if (parsePtr->numWords < 3) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } - simple = 0; nocase = 0; - sawLast = 0; varTokenPtr = parsePtr->tokenPtr; /* - * We only look for -nocase and -- as options. Everything else gets pushed - * to runtime execution. This is different than regexp's runtime option - * handling, but satisfies our stricter needs. + * We only look for -nocase and -- as options. Everything else + * gets pushed to runtime execution. This is different than regexp's + * runtime option handling, but satisfies our stricter needs. */ - for (i = 1; i < parsePtr->numWords - 2; i++) { - varTokenPtr = TokenAfter(varTokenPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Not a simple string, so punt to runtime. - */ - - return TCL_ERROR; + /* Not a simple string - punt to runtime. */ + return TCL_OUT_LINE_COMPILE; } str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { - sawLast++; i++; break; - } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { + } else if ((len > 1) + && (strncmp(str, "-nocase", (unsigned) len) == 0)) { nocase = 1; } else { - /* - * Not an option we recognize. - */ - - return TCL_ERROR; + /* Not an option we recognize. */ + return TCL_OUT_LINE_COMPILE; } } if ((parsePtr->numWords - i) != 2) { - /* - * We don't support capturing to variables. - */ - - return TCL_ERROR; + /* We don't support capturing to variables */ + return TCL_OUT_LINE_COMPILE; } /* - * Get the regexp string. If it is not a simple string or can't be - * converted to a glob pattern, push the word for the INST_REGEXP. - * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. + * Get the regexp string. If it is not a simple string, punt to runtime. + * If it has a '-', it could be an incorrectly formed regexp command. */ + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + str = (char *) varTokenPtr[1].start; + len = varTokenPtr[1].size; + if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) { + return TCL_OUT_LINE_COMPILE; + } - varTokenPtr = TokenAfter(varTokenPtr); - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_DString ds; - - str = (char *) varTokenPtr[1].start; - len = varTokenPtr[1].size; + if (len == 0) { /* - * If it has a '-', it could be an incorrectly formed regexp command. + * The semantics of regexp are always match on re == "". */ + TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); + return TCL_OK; + } - if ((*str == '-') && !sawLast) { - return TCL_ERROR; - } + /* + * Make a copy of the string that is null-terminated for checks which + * require such. + */ + str = (char *) ckalloc((unsigned) len + 1); + strncpy(str, varTokenPtr[1].start, (size_t) len); + str[len] = '\0'; + start = 0; - if (len == 0) { - /* - * The semantics of regexp are always match on re == "". - */ + /* + * Check for anchored REs (ie ^foo$), so we can use string equal if + * possible. Do not alter the start of str so we can free it correctly. + */ + if (str[0] == '^') { + start++; + anchorLeft = 1; + } else { + anchorLeft = 0; + } + if ((str[len-1] == '$') && ((len == 1) || (str[len-2] != '\\'))) { + anchorRight = 1; + str[--len] = '\0'; + } else { + anchorRight = 0; + } - PushLiteral(envPtr, "1", 1); - return TCL_OK; - } + /* + * On the first (pattern) arg, check to see if any RE special characters + * are in the word. If not, this is the same as 'string equal'. + */ + if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) { + start += 2; + anchorLeft = 0; + } + if ((len > (2+start)) && (str[len-3] != '\\') + && (str[len-2] == '.') && (str[len-1] == '*')) { + len -= 2; + str[len] = '\0'; + anchorRight = 0; + } + /* + * Don't do anything with REs with other special chars. Also check if + * this is a bad RE (do this at the end because it can be expensive). + * If so, let it complain at runtime. + */ + if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL) + || (Tcl_RegExpCompile(NULL, str) == NULL)) { + ckfree((char *) str); + return TCL_OUT_LINE_COMPILE; + } + + if (anchorLeft && anchorRight) { + TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start), + envPtr); + } else { /* - * Attempt to convert pattern to glob. If successful, push the - * converted pattern as a literal. + * This needs to find the substring anywhere in the string, so + * use string match and *foo*, with appropriate anchoring. */ - - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) - == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); + char *newStr = ckalloc((unsigned) len + 3); + len -= start; + if (anchorLeft) { + strncpy(newStr, str + start, (size_t) len); + } else { + newStr[0] = '*'; + strncpy(newStr + 1, str + start, (size_t) len++); } + if (!anchorRight) { + newStr[len++] = '*'; + } + newStr[len] = '\0'; + TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr); + ckfree((char *) newStr); } - - if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); - } + ckfree((char *) str); /* - * Push the string arg. + * Push the string arg */ - - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); - - if (simple) { - if (exact && !nocase) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size), envPtr); + } else { + SetLineInformation (parsePtr->numWords-1); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; } + } + + if (anchorLeft && anchorRight && !nocase) { + TclEmitOpcode(INST_STR_EQ, envPtr); } else { - /* - * Pass correct RE compile flags. We use only Int1 (8-bit), but - * that handles all the flags we want to pass. - * Don't use TCL_REG_NOSUB as we may have backrefs. - */ - int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); } return TCL_OK; @@ -3262,191 +2446,117 @@ TclCompileRegexpCmd( * Procedure called to compile the "return" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the particular return command is + * too complex for this function (ie, return with any flags like "-code" + * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that + * the command should be compiled "out of line" (eg, not byte compiled). + * If an error occurs then the interpreter's result contains a standard + * error message. * * Side effects: - * Instructions are added to envPtr to execute the "return" command at - * runtime. + * Instructions are added to envPtr to execute the "return" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileReturnCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +TclCompileReturnCmd(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. */ { - /* - * General syntax: [return ?-option value ...? ?result?] - * An even number of words means an explicit result argument is present. - */ - int level, code, objc, size, status = TCL_OK; - int numWords = parsePtr->numWords; - int explicitResult = (0 == (numWords % 2)); - int numOptionWords = numWords - 1 - explicitResult; - Tcl_Obj *returnOpts, **objv; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ - - /* - * Check for special case which can always be compiled: - * return -options <opts> <msg> - * Unlike the normal [return] compilation, this version does everything at - * runtime so it can handle arbitrary words and not just literals. Note - * that if INST_RETURN_STK wasn't already needed for something else - * ('finally' clause processing) this piece of code would not be present. - */ - - if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) - && (wordTokenPtr[1].size == 8) - && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { - Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); - Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - - CompileWord(envPtr, optsTokenPtr, interp, 2); - CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitOpcode(INST_RETURN_STK, envPtr); - return TCL_OK; - } - - /* - * Allocate some working space. - */ + Tcl_Token *varTokenPtr; + int code; + int index = envPtr->exceptArrayNext - 1; - objv = (Tcl_Obj **) TclStackAlloc(interp, - numOptionWords * sizeof(Tcl_Obj *)); + DefineLineInformation; /* - * Scan through the return options. If any are unknown at compile time, - * there is no value in bytecompiling. Save the option values known in an - * objv array for merging into a return options dictionary. + * If we're not in a procedure, don't compile. */ - for (objc = 0; objc < numOptionWords; objc++) { - objv[objc] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - status = TCL_ERROR; - goto cleanup; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - status = TclMergeReturnOptions(interp, objc, objv, - &returnOpts, &code, &level); - cleanup: - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (TCL_ERROR == status) { - /* - * Something was bogus in the return options. Clear the error message, - * and report back to the compiler that this must be interpreted at - * runtime. - */ - - Tcl_ResetResult(interp); - return TCL_ERROR; + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; } /* - * All options are known at compile time, so we're going to bytecompile. - * Emit instructions to push the result on the stack. + * Look back through the ExceptionRanges of the current CompileEnv, + * from exceptArrayPtr[(exceptArrayNext - 1)] down to + * exceptArrayPtr[0] to see if any of them is an enclosing [catch]. + * If there's an enclosing [catch], don't compile. */ - if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); - } else { - /* - * No explict result argument, so default result is empty string. - */ - - PushLiteral(envPtr, "", 0); + while (index >= 0) { + ExceptionRange range = envPtr->exceptArrayPtr[index]; + if ((range.type == CATCH_EXCEPTION_RANGE) + && (range.catchOffset == -1)) { + return TCL_OUT_LINE_COMPILE; + } + index--; } - /* - * Check for optimization: When [return] is in a proc, and there's no - * enclosing [catch], and there are no return options, then the INST_DONE - * instruction is equivalent, and may be more efficient. - */ - - if (numOptionWords == 0 && envPtr->procPtr != NULL) { - /* - * We have default return options and we're in a proc ... - */ - - int index = envPtr->exceptArrayNext - 1; - int enclosingCatch = 0; - - while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { - enclosingCatch = 1; - break; + switch (parsePtr->numWords) { + case 1: { + /* + * Simple case: [return] + * Just push the literal string "". + */ + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + break; + } + case 2: { + /* + * More complex cases: + * [return "foo"] + * [return $value] + * [return [otherCmd]] + */ + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * [return "foo"] case: the parse token is a simple word, + * so just push it. + */ + TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); + } else { + /* + * Parse token is more complex, so compile it; this handles the + * variable reference and nested command cases. If the + * parse token can be byte-compiled, then this instance of + * "return" will be byte-compiled; otherwise it will be + * out line compiled. + */ + SetLineInformation (1); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } } - index--; + break; } - if (!enclosingCatch) { + default: { /* - * ... and there is no enclosing catch. Issue the maximally - * efficient exit instruction. + * Most complex return cases: everything else, including + * [return -code error], etc. */ - - Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - return TCL_OK; + return TCL_OUT_LINE_COMPILE; } } - /* Optimize [return -level 0 $x]. */ - Tcl_DictObjSize(NULL, returnOpts, &size); - if (size == 0 && level == 0 && code == TCL_OK) { - Tcl_DecrRefCount(returnOpts); - return TCL_OK; - } - /* - * Could not use the optimization, so we push the return options dict, and - * emit the INST_RETURN_IMM instruction with code and level as operands. + * The INST_DONE opcode actually causes the branching out of the + * subroutine, and takes the top stack item as the return result + * (which is why we pushed the value above). */ - - CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); + TclEmitOpcode(INST_DONE, envPtr); return TCL_OK; } - -static void -CompileReturnInternal( - CompileEnv *envPtr, - unsigned char op, - int code, - int level, - Tcl_Obj *returnOpts) -{ - TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(op, code, envPtr); - TclEmitInt4(level, envPtr); -} - -void -TclCompileSyntaxError( - Tcl_Interp *interp, - CompileEnv *envPtr) -{ - Tcl_Obj *msg = Tcl_GetObjResult(interp); - int numBytes; - const char *bytes = TclGetStringFromObj(msg, &numBytes); - - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); - CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, - Tcl_GetReturnOptions(interp, TCL_ERROR)); -} /* *---------------------------------------------------------------------- @@ -3456,54 +2566,77 @@ TclCompileSyntaxError( * Procedure called to compile the "set" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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 + * compilation 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. * * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. + * Instructions are added to envPtr to execute the "set" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileSetCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +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. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, simpleVarName, localIndex, numWords; - DefineLineInformation; /* TIP #280 */ + int code = TCL_OK; + + DefineLineInformation; numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { - return TCL_ERROR; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"set varName ?newValue?\"", -1); + return TCL_ERROR; } isAssignment = (numWords == 3); /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. */ - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar, 1); + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + if (code != TCL_OK) { + goto done; + } /* * If we are doing an assignment, push the new value. */ if (isAssignment) { - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, + valueTokenPtr[1].size), envPtr); + } else { + SetLineInformation (2); + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + } } /* @@ -3512,1158 +2645,351 @@ TclCompileSetCmd( if (simpleVarName) { if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); + 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 { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); + TclEmitOpcode((isAssignment? + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); } } else { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); + 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 { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); + TclEmitOpcode((isAssignment? + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); } } } else { TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringCmpCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string compare" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string compare" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringCmpCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_CMP, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringEqualCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string equal" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string equal" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringEqualCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_EQ, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringIndexCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string index" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string index" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringIndexCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the index operation. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_INDEX, envPtr); - return TCL_OK; + + done: + return code; } /* *---------------------------------------------------------------------- * - * TclCompileStringMatchCmd -- + * TclCompileStringCmd -- * - * Procedure called to compile the simplest and most common form of the - * "string match" command. + * Procedure called to compile the "string" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. * * Side effects: - * Instructions are added to envPtr to execute the "string match" command + * Instructions are added to envPtr to execute the "string" command * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileStringMatchCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int i, length, exactMatch = 0, nocase = 0; - const char *str; - - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Check if we have a -nocase flag. - */ - - if (parsePtr->numWords == 4) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { - /* - * Fail at run time, not in compilation. - */ - - return TCL_ERROR; - } - nocase = 1; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Push the strings to match against each other. - */ - - for (i = 0; i < 2; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if (!nocase && (i == 0)) { - /* - * Trivial matches can be done by 'string equal'. If -nocase - * was specified, we can't do this because INST_STR_EQ has no - * support for nocase. - */ - - Tcl_Obj *copy = Tcl_NewStringObj(str, length); - - Tcl_IncrRefCount(copy); - exactMatch = TclMatchIsTrivial(TclGetString(copy)); - TclDecrRefCount(copy); - } - PushLiteral(envPtr, str, length); - } else { - SetLineInformation (i+1+nocase); - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Push the matcher. - */ - - if (exactMatch) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileStringLenCmd -- - * - * Procedure called to compile the simplest and most common form of the - * "string length" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string length" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringLenCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* - * Here someone is asking for the length of a static string. Just push - * the actual character (not byte) length. - */ +TclCompileStringCmd(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 *opTokenPtr, *varTokenPtr; + Tcl_Obj *opObj; + int index; + int code; + + static CONST char *options[] = { + "bytelength", "compare", "equal", "first", + "index", "is", "last", "length", + "map", "match", "range", "repeat", + "replace", "tolower", "toupper", "totitle", + "trim", "trimleft", "trimright", + "wordend", "wordstart", (char *) NULL + }; + enum options { + STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, + STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, + STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, + STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, + STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, + STR_WORDEND, STR_WORDSTART + }; + + DefineLineInformation; - char buf[TCL_INTEGER_SPACE]; - int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size); - - len = sprintf(buf, "%d", len); - PushLiteral(envPtr, buf, len); - } else { - SetLineInformation (1); - CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_STR_LEN, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSwitchCmd -- - * - * Procedure called to compile the "switch" command. - * - * Results: - * Returns TCL_OK for successful compile, or TCL_ERROR to defer - * evaluation to runtime (either when it is too complex to get the - * semantics right, or when we know for sure that it is an error but need - * the error to happen at the right time). - * - * Side effects: - * Instructions are added to envPtr to execute the "switch" command at - * runtime. - * - * FIXME: - * Stack depths are probably not calculated correctly. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSwitchCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; /* Pointer to tokens in command. */ - int numWords; /* Number of words in command. */ - - Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ - enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; - /* What kind of switch are we doing? */ - - Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ - Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ - int *bodyLines; /* Array of line numbers for body list - * items. */ - int** bodyNext; - int foundDefault; /* Flag to indicate whether a "default" clause - * is present. */ - - JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ - int *fixupTargetArray; /* Array of places for fixups to point at. */ - int fixupCount; /* Number of places to fix up. */ - int contFixIndex; /* Where the first of the jumps due to a group - * of continuation bodies starts, or -1 if - * there aren't any. */ - int contFixCount; /* Number of continuation bodies pointing to - * the current (or next) real body. */ - - int savedStackDepth = envPtr->currStackDepth; - int noCase; /* Has the -nocase flag been given? */ - int foundMode = 0; /* Have we seen a mode flag yet? */ - int i, valueIndex; - DefineLineInformation; /* TIP #280 */ - int* clNext = envPtr->clNext; - - /* - * Only handle the following versions: - * switch ?--? word {pattern body ...} - * switch -exact ?--? word {pattern body ...} - * switch -glob ?--? word {pattern body ...} - * switch -regexp ?--? word {pattern body ...} - * switch -- word simpleWordPattern simpleWordBody ... - * switch -exact -- word simpleWordPattern simpleWordBody ... - * switch -glob -- word simpleWordPattern simpleWordBody ... - * switch -regexp -- word simpleWordPattern simpleWordBody ... - * When the mode is -glob, can also handle a -nocase flag. - * - * First off, we don't care how the command's word was generated; we're - * compiling it anyway! So skip it... - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - valueIndex = 1; - numWords = parsePtr->numWords-1; - - /* - * Check for options. - */ - - noCase = 0; - mode = Switch_Exact; - if (numWords == 2) { - /* - * There's just the switch value and the bodies list. In that case, we - * can skip all option parsing and move on to consider switch values - * and the body list. - */ - - goto finishedOptionParse; - } - - /* - * There must be at least one option, --, because without that there is no - * way to statically avoid the problems you get from strings-to-be-matched - * that start with a - (the interpreted code falls apart if it encounters - * them, so we punt if we *might* encounter them as that is the easiest - * way of emulating the behaviour). - */ - - for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { - register unsigned size = tokenPtr[1].size; - register const char *chrs = tokenPtr[1].start; - - /* - * We only process literal options, and we assume that -e, -g and -n - * are unique prefixes of -exact, -glob and -nocase respectively (true - * at time of writing). Note that -exact and -glob may only be given - * at most once or we bail out (error case). - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { - return TCL_ERROR; - } - - if ((size <= 6) && !memcmp(chrs, "-exact", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Exact; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Glob; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Regexp; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { - noCase = 1; - valueIndex++; - continue; - } else if ((size == 2) && !memcmp(chrs, "--", 2)) { - valueIndex++; - break; - } - - /* - * The switch command has many flags we cannot compile at all (e.g. - * all the RE-related ones) which we must have encountered. Either - * that or we have run off the end. The action here is the same: punt - * to interpreted version. - */ - - return TCL_ERROR; - } - if (numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - numWords--; - if (noCase && (mode == Switch_Exact)) { - /* - * Can't compile this case; no opcode for case-insensitive equality! - */ - - return TCL_ERROR; + if (parsePtr->numWords < 2) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; } + opTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); - /* - * The value to test against is going to always get pushed on the stack. - * But not yet; we need to verify that the rest of the command is - * compilable too. - */ - - finishedOptionParse: - valueTokenPtr = tokenPtr; - /* For valueIndex, see previous loop. */ - tokenPtr = TokenAfter(tokenPtr); - numWords--; - - /* - * Build an array of tokens for the matcher terms and script bodies. Note - * that in the case of the quoted bodies, this is tricky as we cannot use - * copies of the string from the input token for the generated tokens (it - * causes a crash during exception handling). When multiple tokens are - * available at this point, this is pretty easy. - */ - - if (numWords == 1) { - CONST char *bytes; - int maxLen, numBytes; - int bline; /* TIP #280: line of the pattern/action list, - * and start of list for when tracking the - * location. This list comes immediately after - * the value we switch on. */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - bytes = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - - /* Allocate enough space to work in. */ - maxLen = TclMaxListLength(bytes, numBytes, NULL); - if (maxLen < 2) { - return TCL_ERROR; - } - bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * maxLen); - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * maxLen); - bodyLines = (int *) ckalloc(sizeof(int) * maxLen); - bodyNext = (int **) ckalloc(sizeof(int*) * maxLen); - - bline = mapPtr->loc[eclIndex].line[valueIndex+1]; - numWords = 0; - - while (numBytes > 0) { - CONST char *prevBytes = bytes; - int literal; - - if (TCL_OK != TclFindElement(NULL, bytes, numBytes, - &(bodyTokenArray[numWords].start), &bytes, - &(bodyTokenArray[numWords].size), &literal) || !literal) { - abort: - ckfree((char *) bodyToken); - ckfree((char *) bodyTokenArray); - ckfree((char *) bodyLines); - ckfree((char *) bodyNext); - return TCL_ERROR; - } - - bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; - bodyTokenArray[numWords].numComponents = 0; - bodyToken[numWords] = bodyTokenArray + numWords; - + opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size); + if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0, + &index) != TCL_OK) { + Tcl_DecrRefCount(opObj); + Tcl_ResetResult(interp); + return TCL_OUT_LINE_COMPILE; + } + Tcl_DecrRefCount(opObj); + + varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1); + + switch ((enum options) index) { + case STR_BYTELENGTH: + case STR_FIRST: + case STR_IS: + case STR_LAST: + case STR_MAP: + case STR_RANGE: + case STR_REPEAT: + case STR_REPLACE: + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: + case STR_TRIM: + case STR_TRIMLEFT: + case STR_TRIMRIGHT: + case STR_WORDEND: + case STR_WORDSTART: /* - * TIP #280: Now determine the line the list element starts on - * (there is no need to do it earlier, due to the possibility of - * aborting, see above). + * All other cases: compile out of line. */ + return TCL_OUT_LINE_COMPILE; - TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start); - TclAdvanceContinuations (&bline, &clNext, - bodyTokenArray[numWords].start - envPtr->source); - bodyLines[numWords] = bline; - bodyNext[numWords] = clNext; - TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); - TclAdvanceContinuations (&bline, &clNext, bytes - envPtr->source); - - numBytes -= (bytes - prevBytes); - numWords++; - } - if (numWords % 2) { - goto abort; - } - } else if (numWords % 2 || numWords == 0) { - /* - * Odd number of words (>1) available, or no words at all available. - * Both are error cases, so punt and let the interpreted-version - * generate the error message. Note that the second case probably - * should get caught earlier, but it's easy to check here again anyway - * because it'd cause a nasty crash otherwise. - */ - - return TCL_ERROR; - } else { - /* - * Multi-word definition of patterns & actions. - */ - - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *) ckalloc(sizeof(int) * numWords); - bodyNext = (int **) ckalloc(sizeof(int*) * numWords); - bodyTokenArray = NULL; - for (i=0 ; i<numWords ; i++) { + case STR_COMPARE: + case STR_EQUAL: { + int i; /* - * We only handle the very simplest case. Anything more complex is - * a good reason to go to the interpreted case anyway due to - * traces, etc. + * If there are any flags to the command, we can't byte compile it + * because the INST_STR_EQ bytecode doesn't support flags. */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - ckfree((char *) bodyToken); - ckfree((char *) bodyLines); - ckfree((char *) bodyNext); - return TCL_ERROR; + if (parsePtr->numWords != 4) { + return TCL_OUT_LINE_COMPILE; } - bodyToken[i] = tokenPtr+1; - - /* - * TIP #280: Copy line information from regular cmd info. - */ - - bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; - bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; - tokenPtr = TokenAfter(tokenPtr); - } - } - /* - * Fall back to interpreted if the last body is a continuation (it's - * illegal, but this makes the error happen at the right time). - */ - - if (bodyToken[numWords-1]->size == 1 && - bodyToken[numWords-1]->start[0] == '-') { - ckfree((char *) bodyToken); - ckfree((char *) bodyLines); - ckfree((char *) bodyNext); - if (bodyTokenArray != NULL) { - ckfree((char *) bodyTokenArray); - } - return TCL_ERROR; - } - - /* - * Now we commit to generating code; the parsing stage per se is done. - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation (valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* - * Check if we can generate a jump table, since if so that's faster than - * doing an explicit compare with each body. Note that we're definitely - * over-conservative with determining whether we can do the jump table, - * but it handles the most common case well enough. - */ - - if (mode == Switch_Exact) { - JumptableInfo *jtPtr; - int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; - int mustGenerate, jumpToDefault; - Tcl_DString buffer; - Tcl_HashEntry *hPtr; - - /* - * Compile the switch by using a jump table, which is basically a - * hashtable that maps from literal values to match against to the - * offset (relative to the INST_JUMP_TABLE instruction) to jump to. - * The jump table itself is independent of any invokation of the - * bytecode, and as such is stored in an auxData block. - * - * Start by allocating the jump table itself, plus some workspace. - */ - - jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo)); - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - finalFixups = (int *) ckalloc(sizeof(int) * (numWords/2)); - foundDefault = 0; - mustGenerate = 1; - - /* - * Next, issue the instruction to do the jump, together with what we - * want to do if things do not work out (jump to either the default - * clause or the "default" default, which just sets the result to - * empty). Note that we will come back and rewrite the jump's offset - * parameter when we know what it should be, and that all jumps we - * issue are of the wide kind because that makes the code much easier - * to debug! - */ - - jumpLocation = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr); - jumpToDefault = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); - - for (i=0 ; i<numWords ; i+=2) { /* - * For each arm, we must first work out what to do with the match - * term. + * Push the two operands onto the stack. */ - if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || - memcmp(bodyToken[numWords-2]->start, "default", 7)) { - /* - * This is not a default clause, so insert the current - * location as a target in the jump table (assuming it isn't - * already there, which would indicate that this clause is - * probably masked by an earlier one). Note that we use a - * Tcl_DString here simply because the hash API does not let - * us specify the string length. - */ - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, bodyToken[i]->start, - bodyToken[i]->size); - hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, - Tcl_DStringValue(&buffer), &isNew); - if (isNew) { - /* - * First time we've encountered this match clause, so it - * must point to here. - */ - - Tcl_SetHashValue(hPtr, (ClientData) - (CurrentOffset(envPtr) - jumpLocation)); + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size), envPtr); + } else { + SetLineInformation (i); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } } - Tcl_DStringFree(&buffer); - } else { - /* - * This is a default clause, so patch up the fallthrough from - * the INST_JUMP_TABLE instruction to here. - */ - - foundDefault = 1; - isNew = 1; - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } - /* - * Now, for each arm we must deal with the body of the clause. - * - * If this is a continuation body (never true of a final clause, - * whether default or not) we're done because the next jump target - * will also point here, so we advance to the next clause. - */ + TclEmitOpcode(((((enum options) index) == STR_COMPARE) ? + INST_STR_CMP : INST_STR_EQ), envPtr); + return TCL_OK; + } + case STR_INDEX: { + int i; - if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { - mustGenerate = 1; - continue; + if (parsePtr->numWords != 4) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; } /* - * Also skip this arm if its only match clause is masked. (We - * could probably be more aggressive about this, but that would be - * much more difficult to get right.) + * Push the two operands onto the stack. */ - if (!isNew && !mustGenerate) { - continue; + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size), envPtr); + } else { + SetLineInformation (i); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } - mustGenerate = 0; - /* - * Compile the body of the arm. - */ - - envPtr->line = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyNext[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - /* - * Compile a jump in to the end of the command if this body is - * anything other than a user-supplied default arm (to either skip - * over the remaining bodies or the code that generates an empty - * result). - */ - - if (i+2 < numWords || !foundDefault) { - finalFixups[numRealBodies++] = CurrentOffset(envPtr); + TclEmitOpcode(INST_STR_INDEX, envPtr); + return TCL_OK; + } + case STR_LENGTH: { + if (parsePtr->numWords != 3) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* - * Easier by far to issue this jump as a fixed-width jump. - * Otherwise we'd need to do a lot more (and more awkward) - * rewriting when we fixed this all up. + * Here someone is asking for the length of a static string. + * Just push the actual character (not byte) length. */ - - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + char buf[TCL_INTEGER_SPACE]; + int len = Tcl_NumUtfChars(varTokenPtr[1].start, + varTokenPtr[1].size); + len = sprintf(buf, "%d", len); + TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr); + return TCL_OK; + } else { + SetLineInformation (2); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } } + TclEmitOpcode(INST_STR_LEN, envPtr); + return TCL_OK; } + case STR_MATCH: { + int i, length, exactMatch = 0, nocase = 0; + CONST char *str; - /* - * We're at the end. If we've not already done so through the - * processing of a user-supplied default clause, add in a "default" - * default clause now. - */ - - if (!foundDefault) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - PushLiteral(envPtr, "", 0); - } - - /* - * No more instructions to be issued; everything that needs to jump to - * the end of the command is fixed up at this point. - */ - - for (i=0 ; i<numRealBodies ; i++) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i], - envPtr->codeStart+finalFixups[i]+1); - } - - /* - * Clean up all our temporary space and return. - */ - - ckfree((char *) finalFixups); - ckfree((char *) bodyToken); - ckfree((char *) bodyLines); - ckfree((char *) bodyNext); - if (bodyTokenArray != NULL) { - ckfree((char *) bodyTokenArray); - } - return TCL_OK; - } - - /* - * Generate a test for each arm. - */ - - contFixIndex = -1; - contFixCount = 0; - fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords); - fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords); - memset(fixupTargetArray, 0, numWords * sizeof(int)); - fixupCount = 0; - foundDefault = 0; - for (i=0 ; i<numWords ; i+=2) { - int nextArmFixupIndex = -1; - - envPtr->currStackDepth = savedStackDepth + 1; - if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || - memcmp(bodyToken[numWords-2]->start, "default", 7)) { - /* - * Generate the test for the arm. - */ - - switch (mode) { - case Switch_Exact: - TclEmitOpcode(INST_DUP, envPtr); - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitOpcode(INST_STR_EQ, envPtr); - break; - case Switch_Glob: - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); - break; - case Switch_Regexp: { - int simple = 0, exact = 0; - - /* - * Keep in sync with TclCompileRegexpCmd. - */ - - if (bodyToken[i]->type == TCL_TOKEN_TEXT) { - Tcl_DString ds; - - if (bodyToken[i]->size == 0) { - /* - * The semantics of regexps are that they always match - * when the RE == "". - */ - - PushLiteral(envPtr, "1", 1); - break; - } + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } - /* - * Attempt to convert pattern to glob. If successful, push - * the converted pattern. - */ - - if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact) == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - if (!simple) { - TclCompileTokens(interp, bodyToken[i], 1, envPtr); + if (parsePtr->numWords == 5) { + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; } - - TclEmitInstInt4(INST_OVER, 1, envPtr); - if (simple) { - if (exact && !noCase) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); - } + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if ((length > 1) && + strncmp(str, "-nocase", (size_t) length) == 0) { + nocase = 1; } else { - /* - * Pass correct RE compile flags. We use only Int1 - * (8-bit), but that handles all the flags we want to - * pass. Don't use TCL_REG_NOSUB as we may have backrefs - * or capture vars. - */ - - int cflags = TCL_REG_ADVANCED - | (noCase ? TCL_REG_NOCASE : 0); - - TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; } - break; - } - default: - Tcl_Panic("unknown switch mode: %d", mode); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } - /* - * In a fall-through case, we will jump on _true_ to the place - * where the body starts (generated later, with guarantee of this - * ensured earlier; the final body is never a fall-through). - */ - - if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { - if (contFixIndex == -1) { - contFixIndex = fixupCount; - contFixCount = 0; + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if (!nocase && (i == 0)) { + /* + * On the first (pattern) arg, check to see if any + * glob special characters are in the word '*[]?\\'. + * If not, this is the same as 'string equal'. We + * can use strpbrk here because the glob chars are all + * in the ascii-7 range. If -nocase was specified, + * we can't do this because INST_STR_EQ has no support + * for nocase. + */ + Tcl_Obj *copy = Tcl_NewStringObj(str, length); + Tcl_IncrRefCount(copy); + exactMatch = (strpbrk(Tcl_GetString(copy), + "*[]?\\") == NULL); + Tcl_DecrRefCount(copy); + } + TclEmitPush( + TclRegisterNewLiteral(envPtr, str, length), envPtr); + } else { + SetLineInformation (i); + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } } - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - fixupArray+contFixIndex+contFixCount); - fixupCount++; - contFixCount++; - continue; + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount); - nextArmFixupIndex = fixupCount; - fixupCount++; - } else { - /* - * Got a default clause; set a flag to inhibit the generation of - * the jump after the body and the cleanup of the intermediate - * value that we are switching against. - * - * Note that default clauses (which are always terminal clauses) - * cannot be fall-through clauses as well, since the last clause - * is never a fall-through clause (which we have already - * verified). - */ - - foundDefault = 1; - } - - /* - * Generate the body for the arm. This is guaranteed not to be a - * fall-through case, but it might have preceding fall-through cases, - * so we must process those first. - */ - - if (contFixIndex != -1) { - int j; - - for (j=0 ; j<contFixCount ; j++) { - fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr); - } - contFixIndex = -1; - } - - /* - * Now do the actual compilation. Note that we do not use CompileBody - * because we may have synthesized the tokens in a non-standard - * pattern. - */ - - TclEmitOpcode(INST_POP, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - envPtr->line = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyNext[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - if (!foundDefault) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - fixupArray+fixupCount); - fixupCount++; - fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); - } - } - - /* - * Clean up all our temporary space and return. - */ - - ckfree((char *) bodyToken); - ckfree((char *) bodyLines); - ckfree((char *) bodyNext); - if (bodyTokenArray != NULL) { - ckfree((char *) bodyTokenArray); - } - - /* - * Discard the value we are matching against unless we've had a default - * clause (in which case it will already be gone due to the code at the - * start of processing an arm, guaranteed) and make the result of the - * command an empty string. - */ - - if (!foundDefault) { - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - } - - /* - * Do jump fixups for arms that were executed. First, fill in the jumps of - * all jumps that don't point elsewhere to point to here. - */ - - for (i=0 ; i<fixupCount ; i++) { - if (fixupTargetArray[i] == 0) { - fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart; - } - } - - /* - * Now scan backwards over all the jumps (all of which are forward jumps) - * doing each one. When we do one and there is a size changes, we must - * scan back over all the previous ones and see if they need adjusting - * before proceeding with further jump fixups (the interleaved nature of - * all the jumps makes this impossible to do without nested loops). - */ - - for (i=fixupCount-1 ; i>=0 ; i--) { - if (TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { - int j; - - for (j=i-1 ; j>=0 ; j--) { - if (fixupTargetArray[j] > fixupArray[i].codeOffset) { - fixupTargetArray[j] += 3; - } + if (exactMatch) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); } + return TCL_OK; } } - ckfree((char *) fixupArray); - ckfree((char *) fixupTargetArray); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } /* *---------------------------------------------------------------------- * - * DupJumptableInfo, FreeJumptableInfo -- + * TclCompileVariableCmd -- * - * Functions to duplicate, release and print a jump-table created for use - * with the INST_JUMP_TABLE instruction. + * Procedure called to reserve the local variables for the + * "variable" command. The command itself is *not* compiled. * * Results: - * DupJumptableInfo: a copy of the jump-table - * FreeJumptableInfo: none - * PrintJumptableInfo: none + * Always returns TCL_OUT_LINE_COMPILE. * * Side effects: - * DupJumptableInfo: allocates memory - * FreeJumptableInfo: releases memory - * PrintJumptableInfo: none + * Indexed local variables are added to the environment. * *---------------------------------------------------------------------- */ - -static ClientData -DupJumptableInfo( - ClientData clientData) +int +TclCompileVariableCmd(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. */ { - JumptableInfo *jtPtr = clientData; - JumptableInfo *newJtPtr = (JumptableInfo *) - ckalloc(sizeof(JumptableInfo)); - Tcl_HashEntry *hPtr, *newHPtr; - Tcl_HashSearch search; - int isNew; - - Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - while (hPtr != NULL) { - newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable, - Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew); - Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); + Tcl_Token *varTokenPtr; + int i, numWords; + CONST char *varName, *tail; + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; } - return newJtPtr; -} -static void -FreeJumptableInfo( - ClientData clientData) -{ - JumptableInfo *jtPtr = clientData; - - Tcl_DeleteHashTable(&jtPtr->hashTable); - ckfree((char *) jtPtr); -} - -static void -PrintJumptableInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - register JumptableInfo *jtPtr = clientData; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - const char *keyPtr; - int offset, i = 0; - - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { - keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); - offset = PTR2INT(Tcl_GetHashValue(hPtr)); - - if (i++) { - Tcl_AppendToObj(appendObj, ", ", -1); - if (i%4==0) { - Tcl_AppendToObj(appendObj, "\n\t\t", -1); + numWords = parsePtr->numWords; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + for (i = 1; i < numWords; i += 2) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + varName = varTokenPtr[1].start; + tail = varName + varTokenPtr[1].size - 1; + if ((*tail == ')') || (tail < varName)) continue; + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if ((*tail == ':') && (tail > varName)) { + tail++; } + (void) TclFindCompiledLocal(tail, (tail-varName+1), + /*create*/ 1, /*flags*/ 0, envPtr->procPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", - keyPtr, pcOffset + offset); } + return TCL_OUT_LINE_COMPILE; } /* @@ -4674,87 +3000,99 @@ PrintJumptableInfo( * Procedure called to compile the "while" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * Side effects: - * Instructions are added to envPtr to execute the "while" command at - * runtime. + * Instructions are added to envPtr to execute the "while" command + * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileWhileCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +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 jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; + int testCodeOffset, bodyCodeOffset, jumpDist; + int range, code; + char buffer[32 + TCL_INTEGER_SPACE]; int savedStackDepth = envPtr->currStackDepth; - int loopMayEnd = 1; /* This is set to 0 if it is recognized as an - * infinite loop. */ + int loopMayEnd = 1; /* This is set to 0 if it is recognized as + * an infinite loop. */ Tcl_Obj *boolObj; - DefineLineInformation; /* TIP #280 */ + int boolVal; + + DefineLineInformation; 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" {}". + * If the test expression requires substitutions, don't compile the + * while command inline. E.g., the expression might cause the loop to + * never execute or execute forever, as in "while "$x < 5" {}". * - * Bail out also if the body expression requires substitutions in order to - * insure correct behaviour [Bug 219166] + * Bail out also if the body expression requires substitutions + * in order to insure correct behaviour [Bug 219166] */ - testTokenPtr = TokenAfter(parsePtr->tokenPtr); - bodyTokenPtr = TokenAfter(testTokenPtr); - + testTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_ERROR; + return TCL_OUT_LINE_COMPILE; } /* - * Find out if the condition is a constant. + * Find out if the condition is a constant. */ boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); Tcl_IncrRefCount(boolObj); code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); + Tcl_DecrRefCount(boolObj); if (code == TCL_OK) { if (boolVal) { /* - * It is an infinite loop; flag it so that we generate a more - * efficient body. + * it is an infinite loop */ - loopMayEnd = 0; + loopMayEnd = 0; } else { /* - * This is an empty loop: "while 0 {...}" or such. Compile no - * bytecodes. + * This is an empty loop: "while 0 {...}" or such. + * Compile no bytecodes. */ goto pushResult; } } - /* + /* * Create a ExceptionRange record for the loop body. This is used to * implement break and continue. */ - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Jump to the evaluation of the condition. This code uses the "loop @@ -4772,26 +3110,31 @@ TclCompileWhileCmd( if (loopMayEnd) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); - testCodeOffset = 0; /* Avoid compiler warning. */ + testCodeOffset = 0; /* avoid compiler warning */ } else { - /* - * Make sure that the first command in the body is preceded by an - * INST_START_CMD, and hence counted properly. [Bug 1752146] - */ - - envPtr->atCmdStart = 0; - testCodeOffset = CurrentOffset(envPtr); + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); } + /* * Compile the loop body. */ SetLineInformation (2); - bodyCodeOffset = ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); - ExceptionRangeEnds(envPtr, range); + bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"while\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto error; + } + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); /* @@ -4800,7 +3143,7 @@ TclCompileWhileCmd( */ if (loopMayEnd) { - testCodeOffset = CurrentOffset(envPtr); + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; @@ -4808,86 +3151,113 @@ TclCompileWhileCmd( } envPtr->currStackDepth = savedStackDepth; SetLineInformation (1); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"while\" test expression)", -1); + } + goto error; + } envPtr->currStackDepth = savedStackDepth + 1; - - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; + + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } } else { - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); - } + } } + /* * Set the loop's body, continue and break offsets. */ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - ExceptionRangeTarget(envPtr, range, breakOffset); - + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + /* * The while command's result is an empty string. */ - pushResult: + pushResult: envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + envPtr->exceptDepth--; return TCL_OK; + + error: + envPtr->exceptDepth--; + return code; } /* *---------------------------------------------------------------------- * - * PushVarName -- + * TclPushVarName -- * - * Procedure used in the compiling where pushing a variable name is - * necessary (append, lappend, set). + * Procedure used in the compiling where pushing a variable name + * is necessary (append, lappend, set). * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * 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. * * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. + * Instructions are added to envPtr to execute the "set" command + * at runtime. * *---------------------------------------------------------------------- */ static int -PushVarName( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Token *varTokenPtr, /* Points to a variable token. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */ - int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int* clNext) /* Reference to offset of next hidden cont. line */ -{ - register const char *p; - const char *name, *elName; +TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, +#ifndef TCL_TIP280 + simpleVarNamePtr, isScalarPtr) +#else + simpleVarNamePtr, isScalarPtr, line, clNext) +#endif + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Token *varTokenPtr; /* Points to a variable token. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + int flags; /* takes TCL_CREATE_VAR or + * TCL_NO_LARGE_INDEX */ + int *localIndexPtr; /* must not be NULL */ + int *simpleVarNamePtr; /* must not be NULL */ + int *isScalarPtr; /* must not be NULL */ +#ifdef TCL_TIP280 + int line; /* line the token starts on */ + int* clNext; +#endif +{ + 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; + int code = TCL_OK; + + Tcl_Token *elemTokenPtr = NULL; + int elemTokenCount = 0; + int allocedTokens = 0; + int 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; @@ -4897,8 +3267,8 @@ PushVarName( /* * 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 + * 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. */ @@ -4909,33 +3279,31 @@ PushVarName( * 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; - if (name[nameChars-1] == ')') { - /* + if ( *(name + nameChars - 1) == ')') { + /* * last char is ')' => potential array reference. */ - for (i=0,p=name ; i<nameChars ; i++,p++) { + 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. + * An array element, the element name is a simple + * string: assemble the corresponding token. */ - elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp, - sizeof(Tcl_Token)); + elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; @@ -4946,28 +3314,28 @@ PushVarName( } } 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] == ')')) { + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - /* - * Check for parentheses inside first token. + /* + * Check for parentheses inside first token */ - simpleVarName = 0; - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { + simpleVarName = 0; + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { + if (*p == '(') { + simpleVarName = 1; + break; + } + } + 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. + * 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) { @@ -4977,40 +3345,39 @@ PushVarName( 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; + 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 + * Make a first token with the extra characters in the first * token. */ - elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp, - n * sizeof(Tcl_Token)); + elemTokenPtr = (Tcl_Token *) ckalloc(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)); + + memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]), + ((n-1) * sizeof(Tcl_Token))); } else { /* * Use the already available tokens. */ - + elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; + elemTokenCount = n - 1; } } } @@ -5029,25 +3396,23 @@ PushVarName( } /* - * 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*/ flags & TCL_CREATE_VAR, + /*create*/ (flags & TCL_CREATE_VAR), + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), envPtr->procPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { - /* - * We'll push the name. - */ - + /* we'll push the name */ localIndex = -1; } } if (localIndex < 0) { - PushLiteral(envPtr, name, nameChars); + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr); } /* @@ -5056,11 +3421,17 @@ PushVarName( if (elName != NULL) { if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); +#ifdef TCL_TIP280 + envPtr->line = line; + envPtr->clNext = clNext; +#endif + code = TclCompileTokens(interp, elemTokenPtr, + elemTokenCount, envPtr); + if (code != TCL_OK) { + goto done; + } } else { - PushLiteral(envPtr, "", 0); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } } } else { @@ -5068,1406 +3439,28 @@ PushVarName( * The var name isn't simple: compile and push it. */ - envPtr->line = line; - envPtr->clNext = clNext; - CompileTokens(envPtr, varTokenPtr, interp); +#ifdef TCL_TIP280 + envPtr->line = line; + envPtr->clNext = clNext; +#endif + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } } + done: if (removedParen) { ++varTokenPtr[removedParen].size; } if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); - } - *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; - *isScalarPtr = (elName == NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileUnaryOpCmd -- - * - * Utility routine to compile the unary operator commands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileUnaryOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int instruction, - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode(instruction, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileAssociativeBinaryOpCmd -- - * - * Utility routine to compile the binary operator commands that accept an - * arbitrary number of arguments, and that are associative operations. - * Because of the associativity, we may combine operations from right to - * left, saving us any effort of re-ordering the arguments on the stack - * after substitutions are completed. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileAssociativeBinaryOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - const char *identity, - int instruction, - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, identity, -1); - words++; - } - if (words > 3) { - /* - * Reverse order of arguments to get precise agreement with - * [expr] in calcuations, including roundoff errors. - */ - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - } - while (--words > 1) { - TclEmitOpcode(instruction, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileStrictlyBinaryOpCmd -- - * - * Utility routine to compile the binary operator commands, that strictly - * accept exactly two arguments. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileStrictlyBinaryOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int instruction, - CompileEnv *envPtr) -{ - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - return CompileAssociativeBinaryOpCmd(interp, parsePtr, - NULL, instruction, envPtr); -} - -/* - *---------------------------------------------------------------------- - * - * CompileComparisonOpCmd -- - * - * Utility routine to compile the n-ary comparison operator commands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileComparisonOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int instruction, - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords < 3) { - PushLiteral(envPtr, "1", 1); - } else if (parsePtr->numWords == 3) { - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(instruction, envPtr); - } else if (envPtr->procPtr == NULL) { - /* - * No local variable space! - */ - - return TCL_ERROR; - } else { - int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr); - int words; - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(instruction, envPtr); - for (words=3 ; words<parsePtr->numWords ;) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); - } - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - if (++words < parsePtr->numWords) { - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - } - TclEmitOpcode(instruction, envPtr); - } - for (; words>3 ; words--) { - TclEmitOpcode(INST_BITAND, envPtr); - } - - /* - * Drop the value from the temp variable; retaining that reference - * might be expensive elsewhere. - */ - - PushLiteral(envPtr, "", 0); - if (tmpIndex <= 255) { - TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompile*OpCmd -- - * - * Procedures called to compile the corresponding "::tcl::mathop::*" - * commands. These are all wrappers around the utility operator command - * compiler functions, except for the compilers for subtraction and - * division, which are special. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInvertOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr); -} - -int -TclCompileNotOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr); -} - -int -TclCompileAddOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD, - envPtr); -} - -int -TclCompileMulOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT, - envPtr); -} - -int -TclCompileAndOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND, - envPtr); -} - -int -TclCompileOrOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR, - envPtr); -} - -int -TclCompileXorOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR, - envPtr); -} - -int -TclCompilePowOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - /* - * This one has its own implementation because the ** operator is - * the only one with right associativity. - */ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, "1", 1); - words++; - } - while (--words > 1) { - TclEmitOpcode(INST_EXPON, envPtr); - } - return TCL_OK; -} - -int -TclCompileLshiftOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr); -} - -int -TclCompileRshiftOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr); -} - -int -TclCompileModOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr); -} - -int -TclCompileNeqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr); -} - -int -TclCompileStrneqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr); -} - -int -TclCompileInOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr); -} - -int -TclCompileNiOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN, - envPtr); -} - -int -TclCompileLessOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr); -} - -int -TclCompileLeqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr); -} - -int -TclCompileGreaterOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr); -} - -int -TclCompileGeqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr); -} - -int -TclCompileEqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr); -} - -int -TclCompileStreqOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr); -} - -int -TclCompileMinusOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - /* Fallback to direct eval to report syntax error */ - return TCL_ERROR; - } - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (words == 2) { - TclEmitOpcode(INST_UMINUS, envPtr); - return TCL_OK; - } - if (words == 3) { - TclEmitOpcode(INST_SUB, envPtr); - return TCL_OK; - } - /* - * Reverse order of arguments to get precise agreement with - * [expr] in calcuations, including roundoff errors. - */ - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_SUB, envPtr); - } - return TCL_OK; -} - -int -TclCompileDivOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - /* Fallback to direct eval to report syntax error */ - return TCL_ERROR; - } - if (parsePtr->numWords == 2) { - PushLiteral(envPtr, "1.0", 3); - } - for (words=1 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (words <= 3) { - TclEmitOpcode(INST_DIV, envPtr); - return TCL_OK; - } - /* - * Reverse order of arguments to get precise agreement with - * [expr] in calcuations, including roundoff errors. - */ - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_DIV, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * IndexTailVarIfKnown -- - * - * Procedure used in compiling [global] and [variable] commands. It - * inspects the variable name described by varTokenPtr and, if the tail - * is known at compile time, defines a corresponding local variable. - * - * Results: - * Returns the variable's index in the table of compiled locals if the - * tail is known at compile time, or -1 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -IndexTailVarIfKnown( - Tcl_Interp *interp, - Tcl_Token *varTokenPtr, /* Token representing the variable name */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Obj *tailPtr; - const char *tailName, *p; - int len, n = varTokenPtr->numComponents; - Tcl_Token *lastTokenPtr; - int full, localIndex; - - /* - * Determine if the tail is (a) known at compile time, and (b) not an - * array element. Should any of these fail, return an error so that - * the non-compiled command will be called at runtime. - * In order for the tail to be known at compile time, the last token - * in the word has to be constant and contain "::" if it is not the - * only one. - */ - - if (envPtr->procPtr == NULL) { - return -1; - } - - TclNewObj(tailPtr); - if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { - full = 1; - lastTokenPtr = varTokenPtr; - } else { - full = 0; - lastTokenPtr = varTokenPtr + n; - if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { - Tcl_DecrRefCount(tailPtr); - return -1; - } - } - - tailName = TclGetStringFromObj(tailPtr, &len); - - if (len) { - if (*(tailName+len-1) == ')') { - /* - * Possible array: bail out - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - - /* - * Get the tail: immediately after the last '::' - */ - - for(p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p-1) == ':')) { - p++; - break; - } - } - if (!full && (p == tailName)) { - /* - * No :: in the last component - */ - Tcl_DecrRefCount(tailPtr); - return -1; - } - len -= p - tailName; - tailName = p; - } - - localIndex = TclFindCompiledLocal(tailName, len, - /*create*/ TCL_CREATE_VAR, - envPtr->procPtr); - Tcl_DecrRefCount(tailPtr); - return localIndex; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileUpvarCmd -- - * - * Procedure called to compile the "upvar" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "upvar" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileUpvarCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); - - if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords < 3) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Push the frame index if it is known at compile time - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - CallFrame *framePtr; - Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; - - /* - * Attempt to convert to a level reference. Note that TclObjGetFrame - * only changes the obj type when a conversion was successful. - */ - - TclObjGetFrame(interp, objPtr, &framePtr); - newTypePtr = objPtr->typePtr; - Tcl_DecrRefCount(objPtr); - - if (newTypePtr != typePtr) { - if(numWords%2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp, 1); - otherTokenPtr = TokenAfter(tokenPtr); - i = 4; - } else { - if(!(numWords%2)) { - return TCL_ERROR; - } - PushLiteral(envPtr, "1", 1); - otherTokenPtr = tokenPtr; - i = 3; - } - } else { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar, 1); - - if((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); - } - - /* - * Pop the frame index, and set the result to empty - */ - - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNamespaceCmd -- - * - * Procedure called to compile the "namespace" command; currently, only - * the subcommand "namespace upvar" is compiled to bytecodes. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "namespace upvar" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileNamespaceCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Only compile [namespace upvar ...]: needs an odd number of args, >=5 - */ - - numWords = parsePtr->numWords; - if (!(numWords%2) || (numWords < 5)) { - return TCL_ERROR; - } - - /* - * Check if the second argument is "upvar" - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */ - || strncmp(tokenPtr->start, "upvar", 5)) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - localTokenPtr = tokenPtr; - for(i=4; i<=numWords; i+=2) { - otherTokenPtr = TokenAfter(localTokenPtr); - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar, 1); - - if((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileGlobalCmd -- - * - * Procedure called to compile the "global" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "global" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileGlobalCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * 'global' has no effect outside of proc bodies; handle that at runtime - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - PushLiteral(envPtr, "::", 2); - - /* - * Loop over the variables. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for(i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if(localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode(INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileVariableCmd -- - * - * Procedure called to compile the "variable" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "variable" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileVariableCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * Bail out if not compiling a proc body - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Loop over the (var, value) pairs. - */ - - valueTokenPtr = parsePtr->tokenPtr; - for(i=2; i<=numWords; i+=2) { - varTokenPtr = TokenAfter(valueTokenPtr); - valueTokenPtr = TokenAfter(varTokenPtr); - - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if(localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); - - if (i != numWords) { - /* - * A value has been given: set the variable, pop the value - */ - - CompileWord(envPtr, valueTokenPtr, interp, 1); - TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); - TclEmitOpcode(INST_POP, envPtr); - } - } - - /* - * Set the result to empty - */ - - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileEnsemble -- - * - * Procedure called to compile an ensemble command. Note that most - * ensembles are not compiled, since modifying a compiled ensemble causes - * a invalidation of all existing bytecode (expensive!) which is not - * normally warranted. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the subcommands of the - * ensemble at runtime if a compile-time mapping is possible. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileEnsemble( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; - Tcl_Command ensemble = (Tcl_Command) cmdPtr; - Tcl_Parse synthetic; - int len, numBytes, result, flags = 0, i; - const char *word; - - if (parsePtr->numWords < 2) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Too hard. - */ - - return TCL_ERROR; - } - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - - /* - * There's a sporting chance we'll be able to compile this. But now we - * must check properly. To do that, check that we're compiling an ensemble - * that has a compilable command as its appropriate subcommand. - */ - - if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK - || mapObj == NULL) { - /* - * Either not an ensemble or a mapping isn't installed. Crud. Too hard - * to proceed. - */ - - return TCL_ERROR; - } - - /* - * Next, get the flags. We need them on several code paths. - */ - - (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); - - /* - * Check to see if there's also a subcommand list; must check to see if - * the subcommand we are calling is in that list if it exists, since that - * list filters the entries in the map. - */ - - (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); - if (listObj != NULL) { - int sclen; - const char *str; - Tcl_Obj *matchObj = NULL; - - if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { - return TCL_ERROR; - } - for (i=0 ; i<len ; i++) { - str = Tcl_GetStringFromObj(elems[i], &sclen); - if (sclen==numBytes && !memcmp(word, str, (unsigned) numBytes)) { - /* - * Exact match! Excellent! - */ - - result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj); - if (result != TCL_OK || targetCmdObj == NULL) { - return TCL_ERROR; - } - goto doneMapLookup; - } - - /* - * Check to see if we've got a prefix match. A single prefix match - * is fine, and allows us to refine our dictionary lookup, but - * multiple prefix matches is a Bad Thing and will prevent us from - * making progress. Note that we cannot do the lookup immediately - * in the prefix case; might be another entry later in the list - * that causes things to fail. - */ - - if ((flags & TCL_ENSEMBLE_PREFIX) - && strncmp(word, str, (unsigned) numBytes) == 0) { - if (matchObj != NULL) { - return TCL_ERROR; - } - matchObj = elems[i]; - } - } - if (matchObj != NULL) { - result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj); - if (result != TCL_OK || targetCmdObj == NULL) { - return TCL_ERROR; - } - goto doneMapLookup; - } - return TCL_ERROR; - } else { - /* - * No map, so check the dictionary directly. - */ - - TclNewStringObj(subcmdObj, word, numBytes); - result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj); - TclDecrRefCount(subcmdObj); - if (result == TCL_OK && targetCmdObj != NULL) { - /* - * Got it. Skip the fiddling around with prefixes. - */ - - goto doneMapLookup; - } - - /* - * We've not literally got a valid subcommand. But maybe we have a - * prefix. Check if prefix matches are allowed. - */ - - if (flags & TCL_ENSEMBLE_PREFIX) { - Tcl_DictSearch s; - int done, matched; - Tcl_Obj *tmpObj; - - /* - * Iterate over the keys in the dictionary, checking to see if - * we're a prefix. - */ - - Tcl_DictObjFirst(NULL,mapObj,&s,&subcmdObj,&tmpObj,&done); - matched = 0; - while (!done) { - if (strncmp(TclGetString(subcmdObj), word, - (unsigned) numBytes) == 0) { - if (matched++) { - /* - * Must have matched twice! Not unique, so no point - * looking further. - */ - - break; - } - targetCmdObj = tmpObj; - } - Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done); - } - Tcl_DictObjDone(&s); - - /* - * If we have anything other than a single match, we've failed the - * unique prefix check. - */ - - if (matched != 1) { - return TCL_ERROR; - } - } else { - return TCL_ERROR; - } - } - - /* - * OK, we definitely map to something. But what? - * - * The command we map to is the first word out of the map element. Note - * that we also reject dealing with multi-element rewrites if we are in a - * safe interpreter, as there is otherwise a (highly gnarly!) way to make - * Tcl crash open to exploit. - */ - - doneMapLookup: - if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) { - return TCL_ERROR; + ckfree((char *) elemTokenPtr); } - if (len > 1 && Tcl_IsSafe(interp)) { - return TCL_ERROR; - } - targetCmdObj = elems[0]; - - Tcl_IncrRefCount(targetCmdObj); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); - TclDecrRefCount(targetCmdObj); - if (cmdPtr == NULL || cmdPtr->compileProc == NULL - || cmdPtr->flags & CMD_HAS_EXEC_TRACES - || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { - /* - * Maps to an undefined command or a command without a compiler. - * Cannot compile. - */ - - return TCL_ERROR; - } - - /* - * Now we've done the mapping process, can now actually try to compile. - * We do this by handing off to the subcommand's actual compiler. But to - * do that, we have to perform some trickery to rewrite the arguments. - */ - - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - 2 + len; - TclGrowParseTokenArray(&synthetic, 2*len); - synthetic.numTokens = 2*len; - - /* - * Now we have the space to work in, install something rewritten. Note - * that we are here praying for all our might that none of these words are - * a script; the error detection code will crash if that happens and there - * is nothing we can do to avoid it! - */ - - for (i=0 ; i<len ; i++) { - int sclen; - const char *str = Tcl_GetStringFromObj(elems[i], &sclen); - - synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[2*i].start = str; - synthetic.tokenPtr[2*i].size = sclen; - synthetic.tokenPtr[2*i].numComponents = 1; - - synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[2*i+1].start = str; - synthetic.tokenPtr[2*i+1].size = sclen; - synthetic.tokenPtr[2*i+1].numComponents = 0; - } - - /* - * Copy over the real argument tokens. - */ - - for (i=len; i<synthetic.numWords; i++) { - int toCopy; - tokenPtr = TokenAfter(tokenPtr); - toCopy = tokenPtr->numComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - } - - /* - * Hand off compilation to the subcommand compiler. At last! - */ - - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); - - /* - * Clean up if necessary. - */ - - Tcl_FreeParse(&synthetic); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileInfoExistsCmd -- - * - * Procedure called to compile the "info exists" subcommand. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "info exists" - * subcommand at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInfoExistsCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int isScalar, simpleVarName, localIndex; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, - &simpleVarName, &isScalar, 1); - - /* - * Emit instruction to check the variable for existence. - */ - - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_EXIST_STK, envPtr); - } else { - TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr); - } - } - } else { - TclEmitOpcode(INST_EXIST_STK, envPtr); - } - - return TCL_OK; + *localIndexPtr = localIndex; + *simpleVarNamePtr = simpleVarName; + *isScalarPtr = (elName == NULL); + return code; } /* @@ -6477,3 +3470,4 @@ TclCompileInfoExistsCmd( * fill-column: 78 * End: */ + |