tclCompCmds.c Go to the documentation of this file. /* * tclCompCmds.c -- * * 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. * * RCS: @(#) $Id: tclCompCmds.c,v 1.140 2008/01/23 19:41:27 dgp Exp $ */ #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); */ #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]; \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); \ } /* * TIP #280: Remember the per-word line information of the current command. An * index is used instead of a pointer as recursive compilation may reallocate, * i.e. move, the array. This is also the reason to save the nuloc now, it may * change during the course of the function. * * Macro to encapsulate the variable definition and setup. */ #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 /* * 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: */ 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); 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); /* * Flags bits used by PushVarName. */ #define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ #define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. */ 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 */ };  /* *---------------------------------------------------------------------- * * TclCompileAppendCmd -- * * Procedure called to compile the "append" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "append" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileAppendCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; } else if (numWords == 2) { /* * append varName == set varName */ return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); } else if (numWords > 3) { /* * APPEND instructions currently only handle one value. */ return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so * push the new value. This will need to be extended to push a value for * each argument. */ if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } /* * Emit instructions to set/get the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); } else { TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); } else { TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); } } } else { TclEmitOpcode(INST_APPEND_STK, envPtr); } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileBreakCmd -- * * Procedure called to compile the "break" 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 "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. */ { if (parsePtr->numWords != 1) { return TCL_ERROR; } /* * Emit a break instruction. */ TclEmitOpcode(INST_BREAK, envPtr); return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileCatchCmd -- * * Procedure called to compile the "catch" 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 "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. */ { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; const char *name; int resultIndex, optsIndex, nameChars, range; int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. */ if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { return TCL_ERROR; } /* * If variables were specified and the catch command is at global level * (not in a procedure), don't compile it inline: the payoff is too small. */ if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) { return TCL_ERROR; } /* * Make sure the variable names, if any, have no substitutions and just * refer to local scalars. */ 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); /* 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; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start, optsNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr); } } /* * 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); TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); /* * 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] */ envPtr->line = mapPtr->loc[eclIndex].line[1]; if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); ExceptionRangeEnds(envPtr, range); } else { CompileTokens(envPtr, cmdTokenPtr, interp); ExceptionRangeStarts(envPtr, range); TclEmitOpcode(INST_EVAL_STK, envPtr); ExceptionRangeEnds(envPtr, range); } /* * The "no errors" epilogue code: store the body's result into the * variable (if any), push "0" (TCL_OK) as the catch's "no error" result, * and jump around the "error case" code. Note that we issue the push of * the return options first so that if alterations happen to the current * interpreter state during the writing of the variable, we won't see * them; this results in a slightly complex instruction issuing flow * (can't exchange, only duplicate and pop). */ if (resultIndex != -1) { if (optsIndex != -1) { TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); } if (resultIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); } if (optsIndex != -1) { TclEmitOpcode(INST_POP, envPtr); if (optsIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); } } TclEmitOpcode(INST_POP, envPtr); PushLiteral(envPtr, "0", 1); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* * The "error case" code: store the body's result into the variable (if * any), then push the error result code. The initial PC offset here is * the catch's error target. Note that if we are saving the return * options, we do that first so the preservation cannot get affected by * any intermediate result handling. */ envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); if (resultIndex != -1) { if (optsIndex != -1) { TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); } TclEmitOpcode(INST_PUSH_RESULT, envPtr); if (resultIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); if (optsIndex != -1) { if (optsIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); } } TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); /* * Update the target of the jump after the "no errors" code, then emit an * endCatch instruction at the end of the catch command. */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", CurrentOffset(envPtr) - jumpFixup.codeOffset); } TclEmitOpcode(INST_END_CATCH, envPtr); envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" 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 "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. */ { /* * There should be no argument after the "continue". */ if (parsePtr->numWords != 1) { return TCL_ERROR; } /* * Emit a continue instruction. */ TclEmitOpcode(INST_CONTINUE, envPtr); return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileDict*Cmd -- * * Functions called to compile "dict" sucommands. * * Results: * All return TCL_OK for a successful compile, and TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "dict" subcommand at * runtime. * * 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; /* is this necessary? */ 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. */ envPtr->line = mapPtr->loc[eclIndex].line[4]; CompileBody(envPtr, bodyTokenPtr, interp); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode( INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth; /* * 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] */ 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); 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", 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-2, 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. * * Side effects: * 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. */ { Tcl_Token *firstWordPtr; if (parsePtr->numWords == 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; }  /* *---------------------------------------------------------------------- * * TclCompileForCmd -- * * Procedure called to compile the "for" 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 "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. */ { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 5) { return TCL_ERROR; } /* * If the test expression requires substitutions, don't compile the for * command inline. E.g., the expression might cause the loop to never * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". */ startTokenPtr = TokenAfter(parsePtr->tokenPtr); testTokenPtr = TokenAfter(startTokenPtr); if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } /* * Bail out also if the body or the next expression require substitutions * in order to insure correct behaviour [Bug 219166] */ nextTokenPtr = TokenAfter(testTokenPtr); bodyTokenPtr = TokenAfter(nextTokenPtr); if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { return TCL_ERROR; } /* * Create ExceptionRange records for the body and the "next" command. The * "next" command's ExceptionRange supports break but not continue (and * has a -1 continueOffset). */ bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Inline compile the initial command. */ envPtr->line = mapPtr->loc[eclIndex].line[1]; CompileBody(envPtr, startTokenPtr, interp); 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). * "for start cond next body" produces then: * start * goto A * B: body : bodyCodeOffset * next : nextCodeOffset, continueOffset * A: cond -> result : testCodeOffset * if (result) goto B */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); /* * Compile the loop body. */ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); envPtr->line = mapPtr->loc[eclIndex].line[4]; CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Compile the "next" subcommand. */ envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); envPtr->line = mapPtr->loc[eclIndex].line[3]; CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that * terminates the for. */ testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; testCodeOffset += 3; } envPtr->line = mapPtr->loc[eclIndex].line[2]; envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } /* * Fix the starting points of the exception ranges (may have moved due to * jump type modification) and set where the exceptions target. */ envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; ExceptionRangeTarget(envPtr, bodyRange, breakOffset); ExceptionRangeTarget(envPtr, nextRange, breakOffset); /* * The for command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; PushLiteral(envPtr, "", 0); return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileForeachCmd -- * * Procedure called to compile the "foreach" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "foreach" command at * runtime. * *---------------------------------------------------------------------- */ 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. */ { Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ int firstValueTemp; /* Index of the first temp var in the frame * used to point to a value list. */ int loopCtTemp; /* Index of temp var holding the loop's * iteration count. */ Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ /* * We parse the variable list argument words and create two arrays: * varcList[i] is number of variables in i-th var list. * varvList[i] points to array of var names in i-th var list. */ int *varcList; const char ***varvList; /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ if (procPtr == NULL) { return TCL_ERROR; } numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { return TCL_ERROR; } /* * 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); } bodyTokenPtr = tokenPtr; if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } bodyIndex = i-1; /* * 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 **)); /* * 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] */ if (numVars == 0) { code = TCL_ERROR; goto done; } for (j = 0; j < numVars; j++) { const char *varName = varvList[loopIndex][j]; if (!TclIsLocalScalar(varName, (int) strlen(varName))) { code = TCL_ERROR; goto done; } } loopIndex++; } /* * 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); if (loopIndex == 0) { firstValueTemp = tempVar; } } loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, procPtr); /* * Create and initialize the ForeachInfo and ForeachVarList data * structures describing this command. Then create a AuxData record * pointing to the ForeachInfo structure. */ infoPtr = (ForeachInfo *) ckalloc((unsigned) sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; numVars = varcList[loopIndex]; varListPtr = (ForeachVarList *) ckalloc((unsigned) sizeof(ForeachVarList) + numVars*sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { const char *varName = varvList[loopIndex][j]; int nameChars = strlen(varName); varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, nameChars, /*create*/ 1, 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); /* * Evaluate then store each value list in the associated temporary. */ loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { envPtr->line = mapPtr->loc[eclIndex].line[i]; CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); } TclEmitOpcode(INST_POP, envPtr); loopIndex++; } } /* * Initialize the temporary var that holds the count of loop iterations. */ TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); /* * Top of loop code: assign each loop variable and check whether * to terminate the loop. */ ExceptionRangeTarget(envPtr, range, continueOffset); TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* * Inline compile the loop body. */ envPtr->line = mapPtr->loc[eclIndex].line[bodyIndex]; ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Jump back to the test at the top of the loop. Generate a 4 byte jump if * the distance to the test is > 120 bytes. This is conservative and * ensures that we won't have to replace this jump if we later need to * replace the ifFalse jump with a 4 byte jump. */ jumpBackOffset = CurrentOffset(envPtr); jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; if (jumpBackDist > 120) { TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); } else { TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); } /* * Fix the target of the jump after the foreach_step test. */ if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { /* * Update the loop body's starting PC offset since it moved down. */ envPtr->exceptArrayPtr[range].codeOffset += 3; /* * Update the jump back to the test at the top of the loop since it * also moved down 3 bytes. */ jumpBackOffset += 3; jumpPc = (envPtr->codeStart + jumpBackOffset); jumpBackDist += 3; if (jumpBackDist > 120) { TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); } else { TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); } } /* * Set the loop's break target. */ ExceptionRangeTarget(envPtr, range, breakOffset); /* * The foreach command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; PushLiteral(envPtr, "", 0); envPtr->currStackDepth = savedStackDepth + 1; done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { if (varvList[loopIndex] != NULL) { ckfree((char *) varvList[loopIndex]); } } TclStackFree(interp, (void *)varvList); TclStackFree(interp, varcList); return code; }  /* *---------------------------------------------------------------------- * * DupForeachInfo -- * * 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 * structure is returned. * * 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. * *---------------------------------------------------------------------- */ static ClientData DupForeachInfo( ClientData clientData) /* The foreach command's compilation auxiliary * data to duplicate. */ { register ForeachInfo *srcPtr = clientData; ForeachInfo *dupPtr; register ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; dupPtr = (ForeachInfo *) ckalloc((unsigned) sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; dupListPtr = (ForeachVarList *) ckalloc((unsigned) sizeof(ForeachVarList) + numVars*sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; } dupPtr->varLists[i] = dupListPtr; } return dupPtr; }  /* *---------------------------------------------------------------------- * * FreeForeachInfo -- * * Procedure to free a ForeachInfo structure created as auxiliary data * during the compilation of a foreach command. * * Results: * None. * * Side effects: * Storage for the ForeachInfo structure pointed to by the ClientData * argument is freed as is any ForeachVarList record pointed to by the * ForeachInfo structure. * *---------------------------------------------------------------------- */ static void FreeForeachInfo( ClientData clientData) /* The foreach command's compilation auxiliary * data to free. */ { register ForeachInfo *infoPtr = clientData; register ForeachVarList *listPtr; int numLists = infoPtr->numLists; register int i; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; ckfree((char *) listPtr); } ckfree((char *) infoPtr); }  /* *---------------------------------------------------------------------- * * 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. * * Side effects: * 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. */ { JumpFixupArray jumpFalseFixupArray; /* Used to fix the ifFalse jump after each * test when its target PC is determined. */ JumpFixupArray jumpEndFixupArray; /* Used to fix the jump after each "then" body * to the end of the "if" when that PC is * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ int jumpFalseDist, numWords, wordIdx, numBytes, j, code; const char *word; int savedStackDepth = envPtr->currStackDepth; /* Saved stack depth at the start of the first * test; the envPtr current depth is restored * to this value at the start of each test. */ int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ int boolVal; /* Value of static condition. */ int compileScripts = 1; DefineLineInformation; /* TIP #280 */ /* * Only compile the "if" command if all arguments are simple words, in * order to insure correct substitution [Bug 219166] */ tokenPtr = parsePtr->tokenPtr; wordIdx = 0; numWords = parsePtr->numWords; for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); } TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); code = TCL_OK; /* * Each iteration of this loop compiles one "if expr ?then? body" or * "elseif expr ?then? body" clause. */ tokenPtr = parsePtr->tokenPtr; wordIdx = 0; while (wordIdx < numWords) { /* * Stop looping if the token isn't "if" or "elseif". */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((tokenPtr == parsePtr->tokenPtr) || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; } else { break; } if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } /* * Compile the test expression then emit the conditional jump around * the "then" part. */ envPtr->currStackDepth = savedStackDepth; testTokenPtr = tokenPtr; if (realCond) { /* * Find out if the condition is a constant. */ Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); Tcl_IncrRefCount(boolObj); code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); TclDecrRefCount(boolObj); if (code == TCL_OK) { /* * A static condition. */ realCond = 0; if (!boolVal) { compileScripts = 0; } } else { envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, jumpFalseFixupArray.fixup+jumpIndex); } code = TCL_OK; } /* * Skip over the optional "then" before the then clause. */ tokenPtr = TokenAfter(testTokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } } } /* * Compile the "then" command body. */ if (compileScripts) { envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; envPtr->currStackDepth = savedStackDepth; CompileBody(envPtr, tokenPtr, interp); } if (realCond) { /* * Jump to the end of the "if" command. Both jumpFalseFixupArray * and jumpEndFixupArray are indexed by "jumpIndex". */ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { TclExpandJumpFixupArray(&jumpEndFixupArray); } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, jumpEndFixupArray.fixup+jumpIndex); /* * Fix the target of the jumpFalse after the test. Generate a 4 * byte jump if the distance is > 120 bytes. This is conservative, * and ensures that we won't have to replace this jump if we later * also need to replace the proceeding jump to the end of the "if" * with a 4 byte jump. */ if (TclFixupForwardJumpToHere(envPtr, jumpFalseFixupArray.fixup+jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. */ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; } } else if (boolVal) { /* * We were processing an "if 1 {...}"; stop compiling scripts. */ compileScripts = 0; } else { /* * We were processing an "if 0 {...}"; reset so that the rest * (elseif, else) is compiled correctly. */ realCond = 1; compileScripts = 1; } tokenPtr = TokenAfter(tokenPtr); wordIdx++; } /* * Restore the current stack depth in the environment; the "else" clause * (or its default) will add 1 to this. */ envPtr->currStackDepth = savedStackDepth; /* * Check for the optional else clause. Do not compile anything if this was * an "if 1 {...}" case. */ if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { /* * There is an else clause. Skip over the optional "else" word. */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } } if (compileScripts) { /* * Compile the else command body. */ envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; CompileBody(envPtr, tokenPtr, interp); } /* * Make sure there are no words after the else clause. */ wordIdx++; if (wordIdx < numWords) { code = TCL_ERROR; goto done; } } else { /* * No else clause: the "if" command's result is an empty string. */ if (compileScripts) { PushLiteral(envPtr, "", 0); } } /* * Fix the unconditional jumps to the end of the "if" command. */ for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ if (TclFixupForwardJumpToHere(envPtr, jumpEndFixupArray.fixup+jumpIndex, 127)) { /* * Adjust the immediately preceeding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. */ unsigned char *ifFalsePc = envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; unsigned char opCode = *ifFalsePc; if (opCode == INST_JUMP_FALSE1) { jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else if (opCode == INST_JUMP_FALSE4) { jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); } } } /* * Free the jumpFixupArray array if malloc'ed storage was used. */ done: envPtr->currStackDepth = savedStackDepth + 1; TclFreeJumpFixupArray(&jumpFalseFixupArray); TclFreeJumpFixupArray(&jumpEndFixupArray); return code; }  /* *---------------------------------------------------------------------- * * TclCompileIncrCmd -- * * Procedure called to compile the "incr" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "incr" command at * runtime. * *---------------------------------------------------------------------- */ 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. */ { Tcl_Token *varTokenPtr, *incrTokenPtr; int simpleVarName, isScalar, localIndex, haveImmValue, immValue; DefineLineInformation; /* TIP #280 */ if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); /* * If an increment is given, push it, but see first if it's a small * integer. */ haveImmValue = 0; immValue = 1; if (parsePtr->numWords == 3) { incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; int numBytes = incrTokenPtr[1].size; int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); Tcl_IncrRefCount(intObj); code = TclGetIntFromObj(NULL, intObj, &immValue); TclDecrRefCount(intObj); if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } if (!haveImmValue) { PushLiteral(envPtr, word, numBytes); } } else { envPtr->line = mapPtr->loc[eclIndex].line[2]; CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ haveImmValue = 1; } /* * Emit the instruction to increment the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex >= 0) { if (haveImmValue) { TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); } } else { if (haveImmValue) { TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); } } } else { if (localIndex >= 0) { if (haveImmValue) { TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); } } else { if (haveImmValue) { TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); } } } } else { /* Non-simple variable name. */ if (haveImmValue) { TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_STK, envPtr); } } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lappend" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLappendCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; int simpleVarName, isScalar, localIndex, numWords; DefineLineInformation; /* TIP #280 */ /* * If we're not in a procedure, don't compile. */ if (envPtr->procPtr == NULL) { return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; } if (numWords != 3) { /* * LAPPEND instructions currently only handle one value appends. */ return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include * namespace qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); /* * If we are doing an assignment, push the new value. In the no values * case, create an empty object. */ if (numWords > 2) { Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } /* * Emit instructions to set/get the variable. */ /* * The *_STK opcodes should be refactored to make better use of existing * LOAD/STORE instructions. */ if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_LAPPEND_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); } else { TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); } else { TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); } } } else { TclEmitOpcode(INST_LAPPEND_STK, envPtr); } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileLassignCmd -- * * Procedure called to compile the "lassign" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lassign" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLassignCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; int simpleVarName, isScalar, localIndex, numWords, idx; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime. */ if (numWords < 3) { return TCL_ERROR; } /* * Generate code to push list being taken apart by [lassign]. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); /* * Generate code to assign values from the list to variables. */ for (idx=0 ; idx<numWords-2 ; idx++) { tokenPtr = TokenAfter(tokenPtr); /* * Generate the next variable name. */ PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[idx+2]); /* * Emit instructions to get the idx'th item out of the list value on * the stack and assign it to the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex >= 0) { TclEmitOpcode(INST_DUP, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); if (localIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr); } } else { TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); } } else { if (localIndex >= 0) { TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); if (localIndex <= 255) { TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); } } else { TclEmitInstInt4(INST_OVER, 2, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); } } } else { TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); TclEmitOpcode(INST_STORE_STK, envPtr); } 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; } /* * 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); } /* * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are * multiple index args. */ if (numWords == 3) { TclEmitOpcode(INST_LIST_INDEX, envPtr); } else { TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr); } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileListCmd -- * * Procedure called to compile the "list" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "list" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileListCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ /* * If we're not in a procedure, don't compile. */ if (envPtr->procPtr == NULL) { return TCL_ERROR; } if (parsePtr->numWords == 1) { /* * [list] without arguments just pushes an empty object. */ PushLiteral(envPtr, "", 0); } else { /* * Push the all values onto the stack. */ Tcl_Token *valueTokenPtr; int i, numWords; numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileLlengthCmd -- * * Procedure called to compile the "llength" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "llength" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLlengthCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode(INST_LIST_LENGTH, envPtr); return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileLsetCmd -- * * Procedure called to compile the "lset" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lset" command at * runtime. * * The general template for execution of the "lset" command is: * (1) Instructions to push the variable name, unless the variable is * local to the stack frame. * (2) If the variable is an array element, instructions to push the * array element name. * (3) Instructions to push each of zero or more "index" arguments to the * stack, followed with the "newValue" element. * (4) Instructions to duplicate the variable name and/or array element * name onto the top of the stack, if either was pushed at steps (1) * and (2). * (5) The appropriate INST_LOAD_* instruction to place the original * value of the list variable at top of stack. * (6) At this point, the stack contains: * varName? arrayElementName? index1 index2 ... newValue oldList * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST * according as whether there is exactly one index element (LIST) or * either zero or else two or more (FLAT). This instruction removes * everything from the stack except for the two names and pushes the * new value of the variable. * (7) Finally, INST_STORE_* stores the new value in the variable and * cleans up the stack. * *---------------------------------------------------------------------- */ int TclCompileLsetCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { int tempDepth; /* Depth used for emitting one part of the * code burst. */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the variable name. */ int localIndex; /* Index of var in local var table. */ int simpleVarName; /* Flag == 1 if var name is simple. */ int isScalar; /* Flag == 1 if scalar, 0 if array. */ int i; DefineLineInformation; /* TIP #280 */ /* * Check argument count. */ if (parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. */ return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); /* * Push the "index" args and the new element value. */ for (i=2 ; i<parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, i); } /* * Duplicate the variable name if it's been pushed. */ if (!simpleVarName || localIndex < 0) { if (!simpleVarName || isScalar) { tempDepth = parsePtr->numWords - 2; } else { tempDepth = parsePtr->numWords - 1; } TclEmitInstInt4(INST_OVER, tempDepth, envPtr); } /* * Duplicate an array index if one's been pushed. */ if (simpleVarName && !isScalar) { if (localIndex < 0) { tempDepth = parsePtr->numWords - 1; } else { tempDepth = parsePtr->numWords - 2; } TclEmitInstInt4(INST_OVER, tempDepth, envPtr); } /* * Emit code to load the variable's value. */ if (!simpleVarName) { TclEmitOpcode(INST_LOAD_STK, envPtr); } else if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); } else if (localIndex < 0x100) { TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr); } else { TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); } else if (localIndex < 0x100) { TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr); } else { TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr); } } /* * Emit the correct variety of 'lset' instruction. */ if (parsePtr->numWords == 4) { TclEmitOpcode(INST_LSET_LIST, envPtr); } else { TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); } /* * Emit code to put the value back in the variable. */ if (!simpleVarName) { TclEmitOpcode(INST_STORE_STK, envPtr); } else if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); } else if (localIndex < 0x100) { TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); } else if (localIndex < 0x100) { TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); } } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileRegexpCmd -- * * Procedure called to compile the "regexp" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "regexp" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileRegexpCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ int i, len, nocase, exact, sawLast, simple; char *str; DefineLineInformation; /* TIP #280 */ /* * We are only interested in compiling simple regexp cases. Currently * supported compile cases are: * regexp ?-nocase? ?--? staticString $var * regexp ?-nocase? ?--? {^staticString$} $var */ if (parsePtr->numWords < 3) { return TCL_ERROR; } simple = 0; nocase = 0; sawLast = 0; varTokenPtr = parsePtr->tokenPtr; /* * We only look for -nocase and -- as options. Everything else gets pushed * to runtime execution. This is different than regexp's runtime option * handling, but satisfies our stricter needs. */ for (i = 1; i < parsePtr->numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * Not a simple string, so punt to runtime. */ return TCL_ERROR; } str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { sawLast++; i++; break; } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { nocase = 1; } else { /* * Not an option we recognize. */ return TCL_ERROR; } } if ((parsePtr->numWords - i) != 2) { /* * We don't support capturing to variables. */ return TCL_ERROR; } /* * Get the regexp string. If it is not a simple string or can't be * converted to a glob pattern, push the word for the INST_REGEXP. * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. */ varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { Tcl_DString ds; str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; /* * If it has a '-', it could be an incorrectly formed regexp command. */ if ((*str == '-') && !sawLast) { return TCL_ERROR; } if (len == 0) { /* * The semantics of regexp are always match on re == "". */ PushLiteral(envPtr, "1", 1); return TCL_OK; } /* * Attempt to convert pattern to glob. If successful, push the * converted pattern as a literal. */ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } } if (!simple) { CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); } /* * Push the string arg. */ varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); if (simple) { if (exact && !nocase) { TclEmitOpcode(INST_STR_EQ, envPtr); } else { TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); } } else { /* * Pass correct RE compile flags. We use only Int1 (8-bit), but * that handles all the flags we want to pass. * Don't use TCL_REG_NOSUB as we may have backrefs. */ int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); TclEmitInstInt1(INST_REGEXP, cflags, envPtr); } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileReturnCmd -- * * Procedure called to compile the "return" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "return" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileReturnCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { /* * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ int level, code, objc, size, status = TCL_OK; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ /* * Check for special case which can always be compiled: * return -options <opts> <msg> * Unlike the normal [return] compilation, this version does everything at * runtime so it can handle arbitrary words and not just literals. Note * that if INST_RETURN_STK wasn't already needed for something else * ('finally' clause processing) this piece of code would not be present. */ if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && (wordTokenPtr[1].size == 8) && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); TclEmitOpcode(INST_RETURN_STK, envPtr); return TCL_OK; } /* * Allocate some working space. */ objv = (Tcl_Obj **) TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); /* * Scan through the return options. If any are unknown at compile time, * there is no value in bytecompiling. Save the option values known in an * objv array for merging into a return options dictionary. */ for (objc = 0; objc < numOptionWords; objc++) { objv[objc] = Tcl_NewObj(); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; status = TCL_ERROR; goto cleanup; } wordTokenPtr = TokenAfter(wordTokenPtr); } status = TclMergeReturnOptions(interp, objc, objv, &returnOpts, &code, &level); cleanup: while (--objc >= 0) { TclDecrRefCount(objv[objc]); } TclStackFree(interp, objv); if (TCL_ERROR == status) { /* * Something was bogus in the return options. Clear the error message, * and report back to the compiler that this must be interpreted at * runtime. */ Tcl_ResetResult(interp); return TCL_ERROR; } /* * All options are known at compile time, so we're going to bytecompile. * Emit instructions to push the result on the stack. */ if (explicitResult) { CompileWord(envPtr, wordTokenPtr, interp, numWords-1); } else { /* * No explict result argument, so default result is empty string. */ PushLiteral(envPtr, "", 0); } /* * 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; } index--; } if (!enclosingCatch) { /* * ... and there is no enclosing catch. Issue the maximally * efficient exit instruction. */ Tcl_DecrRefCount(returnOpts); TclEmitOpcode(INST_DONE, envPtr); return TCL_OK; } } /* Optimize [return -level 0 $x]. */ Tcl_DictObjSize(NULL, returnOpts, &size); if (size == 0 && level == 0 && code == TCL_OK) { return TCL_OK; } /* * Could not use the optimization, so we push the return options dict, and * emit the INST_RETURN_IMM instruction with code and level as operands. */ CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; } static void CompileReturnInternal( CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts) { TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(op, code, envPtr); TclEmitInt4(level, envPtr); } void TclCompileSyntaxError( Tcl_Interp *interp, CompileEnv *envPtr) { Tcl_Obj *msg = Tcl_GetObjResult(interp); int numBytes; const char *bytes = TclGetStringFromObj(msg, &numBytes); TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, Tcl_GetReturnOptions(interp, TCL_ERROR)); }  /* *---------------------------------------------------------------------- * * TclCompileSetCmd -- * * Procedure called to compile the "set" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "set" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileSetCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, simpleVarName, localIndex, numWords; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; } isAssignment = (numWords == 3); /* * 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); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); /* * If we are doing an assignment, push the new value. */ if (isAssignment) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } /* * Emit instructions to set/get the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); } else if (localIndex <= 255) { TclEmitInstInt1((isAssignment? INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), localIndex, envPtr); } else { TclEmitInstInt4((isAssignment? INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); } else if (localIndex <= 255) { TclEmitInstInt1((isAssignment? INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), localIndex, envPtr); } else { TclEmitInstInt4((isAssignment? INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), localIndex, envPtr); } } } else { TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileStringCmpCmd -- * * Procedure called to compile the simplest and most common form of the * "string compare" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "string compare" * command at runtime. * *---------------------------------------------------------------------- */ int TclCompileStringCmpCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; /* * We don't support any flags; the bytecode isn't that sophisticated. */ if (parsePtr->numWords != 3) { return TCL_ERROR; } /* * Push the two operands onto the stack and then the test. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); TclEmitOpcode(INST_STR_CMP, envPtr); return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileStringEqualCmd -- * * Procedure called to compile the simplest and most common form of the * "string equal" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "string equal" command * at runtime. * *---------------------------------------------------------------------- */ int TclCompileStringEqualCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; /* * We don't support any flags; the bytecode isn't that sophisticated. */ if (parsePtr->numWords != 3) { return TCL_ERROR; } /* * Push the two operands onto the stack and then the test. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); TclEmitOpcode(INST_STR_EQ, envPtr); return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileStringIndexCmd -- * * Procedure called to compile the simplest and most common form of the * "string index" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "string index" command * at runtime. * *---------------------------------------------------------------------- */ int TclCompileStringIndexCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; if (parsePtr->numWords != 3) { return TCL_ERROR; } /* * Push the two operands onto the stack and then the index operation. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); TclEmitOpcode(INST_STR_INDEX, envPtr); return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileStringMatchCmd -- * * Procedure called to compile the simplest and most common form of the * "string match" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "string match" command * at runtime. * *---------------------------------------------------------------------- */ int TclCompileStringMatchCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i, length, exactMatch = 0, nocase = 0; const char *str; if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); /* * Check if we have a -nocase flag. */ if (parsePtr->numWords == 4) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } str = tokenPtr[1].start; length = tokenPtr[1].size; if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { /* * Fail at run time, not in compilation. */ return TCL_ERROR; } nocase = 1; tokenPtr = TokenAfter(tokenPtr); } /* * Push the strings to match against each other. */ for (i = 0; i < 2; i++) { if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { str = tokenPtr[1].start; length = tokenPtr[1].size; if (!nocase && (i == 0)) { /* * Trivial matches can be done by 'string equal'. If -nocase * was specified, we can't do this because INST_STR_EQ has no * support for nocase. */ Tcl_Obj *copy = Tcl_NewStringObj(str, length); Tcl_IncrRefCount(copy); exactMatch = TclMatchIsTrivial(TclGetString(copy)); TclDecrRefCount(copy); } PushLiteral(envPtr, str, length); } else { envPtr->line = mapPtr->loc[eclIndex].line[i+1+nocase]; CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); } /* * Push the matcher. */ if (exactMatch) { TclEmitOpcode(INST_STR_EQ, envPtr); } else { TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); } return TCL_OK; }  /* *---------------------------------------------------------------------- * * TclCompileStringLenCmd -- * * Procedure called to compile the simplest and most common form of the * "string length" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "string length" * command at runtime. * *---------------------------------------------------------------------- */ int TclCompileStringLenCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* * Here someone is asking for the length of a static string. Just push * the actual character (not byte) length. */ char buf[TCL_INTEGER_SPACE]; int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size); len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { envPtr->line = mapPtr->loc[eclIndex].line[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 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 isListedArms = 0; int i, valueIndex; DefineLineInformation; /* TIP #280 */ /* * 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; } /* * 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) { Tcl_DString bodyList; const char **argv = NULL, *tokenStartPtr, *p; int bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ int isTokenBraced; /* * Test that we've got a suitable body list as a simple (i.e. braced) * word, and that the elements of the body are simple words too. This * is really rather nasty indeed. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } Tcl_DStringInit(&bodyList); Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords, &argv) != TCL_OK) { Tcl_DStringFree(&bodyList); return TCL_ERROR; } Tcl_DStringFree(&bodyList); /* * Now we know what the switch arms are, we've got to see whether we * can synthesize tokens for the arms. First check whether we've got a * valid number of arms since we can do that now. */ if (numWords == 0 || numWords % 2) { ckfree((char *) argv); return TCL_ERROR; } isListedArms = 1; bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); bodyLines = (int *) ckalloc(sizeof(int) * numWords); /* * Locate the start of the arms within the overall word. */ bline = mapPtr->loc[eclIndex].line[valueIndex+1]; p = tokenStartPtr = tokenPtr[1].start; while (isspace(UCHAR(*tokenStartPtr))) { tokenStartPtr++; } if (*tokenStartPtr == '{') { tokenStartPtr++; isTokenBraced = 1; } else { isTokenBraced = 0; } /* * TIP #280: Count lines within the literal list. */ for (i=0 ; i<numWords ; i++) { bodyTokenArray[i].type = TCL_TOKEN_TEXT; bodyTokenArray[i].start = tokenStartPtr; bodyTokenArray[i].size = strlen(argv[i]); bodyTokenArray[i].numComponents = 0; bodyToken[i] = bodyTokenArray+i; tokenStartPtr += bodyTokenArray[i].size; /* * Test to see if we have guessed the end of the word correctly; * if not, we can't feed the real string to the sub-compilation * engine, and we're then stuck and so have to punt out to doing * everything at runtime. */ if ((isTokenBraced && *(tokenStartPtr++) != '}') || (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size && !isspace(UCHAR(*tokenStartPtr)))) { ckfree((char *) argv); ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); return TCL_ERROR; } /* * TIP #280: Now determine the line the list element starts on * (there is no need to do it earlier, due to the possibility of * aborting, see above). */ TclAdvanceLines(&bline, p, bodyTokenArray[i].start); bodyLines[i] = bline; p = bodyTokenArray[i].start; while (isspace(UCHAR(*tokenStartPtr))) { tokenStartPtr++; if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) { break; } } if (*tokenStartPtr == '{') { tokenStartPtr++; isTokenBraced = 1; } else { isTokenBraced = 0; } } ckfree((char *) argv); /* * Check that we've parsed everything we thought we were going to * parse. If not, something odd is going on (I believe it is possible * to defeat the code above) and we should bail out. */ if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { /* * Odd number of words (>1) available, or no words at all available. * Both are error cases, so punt and let the interpreted-version * generate the error message. Note that the second case probably * should get caught earlier, but it's easy to check here again anyway * because it'd cause a nasty crash otherwise. */ return TCL_ERROR; } else { /* * Multi-word definition of patterns & actions. */ bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); bodyLines = (int *) ckalloc(sizeof(int) * numWords); bodyTokenArray = NULL; for (i=0 ; i<numWords ; i++) { /* * We only handle the very simplest case. Anything more complex is * a good reason to go to the interpreted case anyway due to * traces, etc. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr->numComponents != 1) { ckfree((char *) bodyToken); ckfree((char *) bodyLines); return TCL_ERROR; } bodyToken[i] = tokenPtr+1; /* * TIP #280: Copy line information from regular cmd info. */ bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; 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); 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. */ envPtr->line = mapPtr->loc[eclIndex].line[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 (isListedArms && mode == Switch_Exact && !noCase) { JumptableInfo *jtPtr; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, jumpToDefault; Tcl_DString buffer; Tcl_HashEntry *hPtr; /* * Compile the switch by using a jump table, which is basically a * hashtable that maps from literal values to match against to the * offset (relative to the INST_JUMP_TABLE instruction) to jump to. * The jump table itself is independent of any invokation of the * bytecode, and as such is stored in an auxData block. * * Start by allocating the jump table itself, plus some workspace. */ jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = (int *) ckalloc(sizeof(int) * (numWords/2)); foundDefault = 0; mustGenerate = 1; /* * Next, issue the instruction to do the jump, together with what we * want to do if things do not work out (jump to either the default * clause or the "default" default, which just sets the result to * empty). Note that we will come back and rewrite the jump's offset * parameter when we know what it should be, and that all jumps we * issue are of the wide kind because that makes the code much easier * to debug! */ jumpLocation = CurrentOffset(envPtr); TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr); jumpToDefault = CurrentOffset(envPtr); TclEmitInstInt4(INST_JUMP4, 0, envPtr); for (i=0 ; i<numWords ; i+=2) { /* * For each arm, we must first work out what to do with the match * term. */ if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || memcmp(bodyToken[numWords-2]->start, "default", 7)) { /* * 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)); } Tcl_DStringFree(&buffer); } else { /* * This is a default clause, so patch up the fallthrough from * the INST_JUMP_TABLE instruction to here. */ foundDefault = 1; isNew = 1; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); } /* * Now, for each arm we must deal with the body of the clause. * * If this is a continuation body (never true of a final clause, * whether default or not) we're done because the next jump target * will also point here, so we advance to the next clause. */ if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { mustGenerate = 1; continue; } /* * Also skip this arm if its only match clause is masked. (We * could probably be more aggressive about this, but that would be * much more difficult to get right.) */ if (!isNew && !mustGenerate) { continue; } mustGenerate = 0; /* * Compile the body of the arm. */ envPtr->line = bodyLines[i+1]; /* TIP #280 */ 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); /* * 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. */ TclEmitInstInt4(INST_JUMP4, 0, envPtr); } } /* * We're at the end. If we've not already done so through the * processing of a user-supplied default clause, add in a "default" * default clause now. */ if (!foundDefault) { TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); PushLiteral(envPtr, "", 0); } /* * No more instructions to be issued; everything that needs to jump to * the end of the command is fixed up at this point. */ for (i=0 ; i<numRealBodies ; i++) { TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i], envPtr->codeStart+finalFixups[i]+1); } /* * Clean up all our temporary space and return. */ ckfree((char *) finalFixups); ckfree((char *) bodyToken); ckfree((char *) bodyLines); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } return TCL_OK; } /* * Generate a test for each arm. */ contFixIndex = -1; contFixCount = 0; fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords); fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords); memset(fixupTargetArray, 0, numWords * sizeof(int)); fixupCount = 0; foundDefault = 0; for (i=0 ; i<numWords ; i+=2) { int nextArmFixupIndex = -1; envPtr->currStackDepth = savedStackDepth + 1; if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || memcmp(bodyToken[numWords-2]->start, "default", 7)) { /* * Generate the test for the arm. */ switch (mode) { case Switch_Exact: TclEmitOpcode(INST_DUP, envPtr); TclCompileTokens(interp, bodyToken[i], 1, envPtr); TclEmitOpcode(INST_STR_EQ, envPtr); break; case Switch_Glob: TclCompileTokens(interp, bodyToken[i], 1, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); break; case Switch_Regexp: { int simple = 0, exact = 0; /* * Keep in sync with TclCompileRegexpCmd. */ if (bodyToken[i]->type == TCL_TOKEN_TEXT) { Tcl_DString ds; if (bodyToken[i]->size == 0) { /* * The semantics of regexps are that they always match * when the RE == "". */ PushLiteral(envPtr, "1", 1); break; } /* * Attempt to convert pattern to glob. If successful, push * the converted pattern. */ if (TclReToGlob(NULL, bodyToken[i]->start, bodyToken[i]->size, &ds, &exact) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } } if (!simple) { TclCompileTokens(interp, bodyToken[i], 1, envPtr); } TclEmitInstInt4(INST_OVER, 1, envPtr); if (simple) { if (exact && !noCase) { TclEmitOpcode(INST_STR_EQ, envPtr); } else { TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); } } else { /* * Pass correct RE compile flags. We use only Int1 * (8-bit), but that handles all the flags we want to * pass. Don't use TCL_REG_NOSUB as we may have backrefs * or capture vars. */ int cflags = TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0); TclEmitInstInt1(INST_REGEXP, cflags, envPtr); } break; } default: Tcl_Panic("unknown switch mode: %d", mode); } /* * In a fall-through case, we will jump on _true_ to the place * where the body starts (generated later, with guarantee of this * ensured earlier; the final body is never a fall-through). */ if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { if (contFixIndex == -1) { contFixIndex = fixupCount; contFixCount = 0; } TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, fixupArray+contFixIndex+contFixCount); fixupCount++; contFixCount++; continue; } TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount); nextArmFixupIndex = fixupCount; fixupCount++; } else { /* * Got a default clause; set a flag to inhibit the generation of * the jump after the body and the cleanup of the intermediate * value that we are switching against. * * Note that default clauses (which are always terminal clauses) * cannot be fall-through clauses as well, since the last clause * is never a fall-through clause (which we have already * verified). */ foundDefault = 1; } /* * Generate the body for the arm. This is guaranteed not to be a * fall-through case, but it might have preceding fall-through cases, * so we must process those first. */ if (contFixIndex != -1) { int j; for (j=0 ; j<contFixCount ; j++) { fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr); } contFixIndex = -1; } /* * Now do the actual compilation. Note that we do not use CompileBody * because we may have synthesized the tokens in a non-standard * pattern. */ TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth + 1; envPtr->line = bodyLines[i+1]; /* TIP #280 */ 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); 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; } } } } ckfree((char *) fixupArray); ckfree((char *) fixupTargetArray); envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; }  /* *---------------------------------------------------------------------- * * DupJumptableInfo, FreeJumptableInfo -- * * Functions to duplicate, release and print a jump-table created for use * with the INST_JUMP_TABLE instruction. * * Results: * DupJumptableInfo: a copy of the jump-table * FreeJumptableInfo: none * PrintJumptableInfo: none * * Side effects: * DupJumptableInfo: allocates memory * FreeJumptableInfo: releases memory * PrintJumptableInfo: none * *---------------------------------------------------------------------- */ static ClientData DupJumptableInfo( ClientData clientData) { JumptableInfo *jtPtr = clientData; JumptableInfo *newJtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo)); Tcl_HashEntry *hPtr, *newHPtr; Tcl_HashSearch search; int isNew; Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); while (hPtr != NULL) { newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable, Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew); Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); } return newJtPtr; } static void FreeJumptableInfo( ClientData clientData) { JumptableInfo *jtPtr = clientData; Tcl_DeleteHashTable(&jtPtr->hashTable); ckfree((char *) jtPtr); } static void PrintJumptableInfo( ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset) { register JumptableInfo *jtPtr = clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; int offset, i = 0; hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); offset = PTR2INT(Tcl_GetHashValue(hPtr)); if (i++) { Tcl_AppendToObj(appendObj, ", ", -1); if (i%4==0) { Tcl_AppendToObj(appendObj, "\n\t\t", -1); } } Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", keyPtr, pcOffset + offset); } }  /* *---------------------------------------------------------------------- * * TclCompileWhileCmd -- * * Procedure called to compile the "while" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "while" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileWhileCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; int savedStackDepth = envPtr->currStackDepth; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } /* * If the test expression requires substitutions, don't compile the while * command inline. E.g., the expression might cause the loop to never * execute or execute forever, as in "while "$x < 5" {}". * * Bail out also if the body expression requires substitutions in order to * insure correct behaviour [Bug 219166] */ testTokenPtr = TokenAfter(parsePtr->tokenPtr); bodyTokenPtr = TokenAfter(testTokenPtr); if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { return TCL_ERROR; } /* * 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); if (code == TCL_OK) { if (boolVal) { /* * It is an infinite loop; flag it so that we generate a more * efficient body. */ loopMayEnd = 0; } else { /* * This is an empty loop: "while 0 {...}" or such. Compile no * bytecodes. */ goto pushResult; } } /* * Create a ExceptionRange record for the loop body. This is used to * implement break and continue. */ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). * "while cond body" produces then: * goto A * B: body : bodyCodeOffset * A: cond -> result : testCodeOffset, continueOffset * if (result) goto B * * The infinite loop "while 1 body" produces: * B: body : all three offsets here * goto B */ if (loopMayEnd) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); testCodeOffset = 0; /* Avoid compiler warning. */ } else { /* * Make sure that the first command in the body is preceded by an * INST_START_CMD, and hence counted properly. [Bug 1752146] */ envPtr->atCmdStart = 0; testCodeOffset = CurrentOffset(envPtr); } /* * Compile the loop body. */ envPtr->line = mapPtr->loc[eclIndex].line[2]; bodyCodeOffset = ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Compile the test expression then emit the conditional jump that * terminates the while. We already know it's a simple word. */ if (loopMayEnd) { testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; envPtr->line = mapPtr->loc[eclIndex].line[1]; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } } else { jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); } } /* * Set the loop's body, continue and break offsets. */ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; ExceptionRangeTarget(envPtr, range, breakOffset); /* * The while command's result is an empty string. */ pushResult: envPtr->currStackDepth = savedStackDepth; PushLiteral(envPtr, "", 0); return TCL_OK; }  /* *---------------------------------------------------------------------- * * PushVarName -- * * 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. * * Side effects: * 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. */ { register const char *p; const char *name, *elName; register int i, n; Tcl_Token *elemTokenPtr = NULL; int nameChars, elNameChars, simpleVarName, localIndex; int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ simpleVarName = 0; name = elName = NULL; nameChars = elNameChars = 0; localIndex = -1; /* * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether * curly braces surround the variable name. This really matters for array * elements to handle things like * set {x($foo)} 5 * which raises an undefined var error if we are not careful here. */ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && (varTokenPtr->start[0] != '{')) { /* * A simple variable name. Divide it up into "name" and "elName" * strings. If it is not a local variable, look it up at runtime. */ simpleVarName = 1; name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (name[nameChars-1] == ')') { /* * last char is ')' => potential array reference. */ for (i=0,p=name ; i<nameChars ; i++,p++) { if (*p == '(') { elName = p + 1; elNameChars = nameChars - i - 2; nameChars = i; break; } } if ((elName != NULL) && elNameChars) { /* * An array element, the element name is a simple string: * assemble the corresponding token. */ elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp, sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = elNameChars; elemTokenPtr->numComponents = 0; elemTokenCount = 1; } } } else if (((n = varTokenPtr->numComponents) > 1) && (varTokenPtr[1].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { /* * 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) { int remainingChars; /* * Check the last token: if it is just ')', do not count it. * Otherwise, remove the ')' and flag so that it is restored at * the end. */ if (varTokenPtr[n].size == 1) { --n; } else { --varTokenPtr[n].size; removedParen = n; } name = varTokenPtr[1].start; nameChars = p - varTokenPtr[1].start; elName = p + 1; remainingChars = (varTokenPtr[2].start - p) - 1; elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; if (remainingChars) { /* * Make a first token with the extra characters in the first * token. */ elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp, n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = remainingChars; elemTokenPtr->numComponents = 0; elemTokenCount = n; /* * Copy the remaining tokens. */ memcpy(elemTokenPtr+1, varTokenPtr+2, (n-1) * sizeof(Tcl_Token)); } else { /* * Use the already available tokens. */ elemTokenPtr = &varTokenPtr[2]; elemTokenCount = n - 1; } } } if (simpleVarName) { /* * See whether name has any namespace separators (::'s). */ int hasNsQualifiers = 0; for (i = 0, p = name; i < nameChars; i++, p++) { if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { hasNsQualifiers = 1; break; } } /* * Look up the var name's index in the array of local vars in the proc * frame. If retrieving the var's value and it doesn't already exist, * push its name and look it up at runtime. */ if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { localIndex = TclFindCompiledLocal(name, nameChars, /*create*/ flags & TCL_CREATE_VAR, envPtr->procPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { /* * We'll push the name. */ localIndex = -1; } } if (localIndex < 0) { PushLiteral(envPtr, name, nameChars); } /* * Compile the element script, if any. */ if (elName != NULL) { if (elNameChars) { envPtr->line = line; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { PushLiteral(envPtr, "", 0); } } } else { /* * The var name isn't simple: compile and push it. */ envPtr->line = line; CompileTokens(envPtr, varTokenPtr, interp); } 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); PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[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); PushVarName(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[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; } 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) { /* * 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); PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); /* * Emit instruction to check the variable for existence. */ if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_EXIST_STK, envPtr); } else { TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr); } else { TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr); } } } else { TclEmitOpcode(INST_EXIST_STK, envPtr); } return TCL_OK; }  /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */

• ソフトウェア開発
• ホームページ制作
• Doxygen版
• STLport版