/* * tclCompCmdsSZ.c -- * * This file contains compilation procedures that compile various Tcl * commands (beginning with the letters 's' through 'z', except for * [upvar] and [variable]) into a sequence of instructions ("bytecodes"). * Also includes the operator command compilers. * * 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-2010 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. */ #include "tclInt.h" #include "tclCompile.h" #include "tclStringTrim.h" /* * Prototypes for procedures defined later in this file: */ 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 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 IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, int valueIndex, int numWords, Tcl_Token **bodyToken, int *bodyLines, int **bodyNext); static void IssueSwitchJumpTable(Tcl_Interp *interp, CompileEnv *envPtr, int valueIndex, int numWords, Tcl_Token **bodyToken, int *bodyLines, int **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, int *optionVarIndices, Tcl_Token **handlerTokens); static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, int *optionVarIndices, Tcl_Token **handlerTokens, Tcl_Token *finallyToken); static int IssueTryFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, Tcl_Token *finallyToken); /* * The structures below define the AuxData types defined in this file. */ const AuxDataType tclJumptableInfoType = { "JumptableInfo", /* name */ DupJumptableInfo, /* dupProc */ FreeJumptableInfo, /* freeProc */ PrintJumptableInfo /* printProc */ }; /* * Shorthand macros for instruction issuing. */ #define OP(name) TclEmitOpcode(INST_##name, envPtr) #define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) #define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) #define OP14(name,val1,val2) \ TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr) #define FIXJUMP4(var) \ TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) #define JUMP1(name,var) \ (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr) #define FIXJUMP1(var) \ TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) #define LOAD(idx) \ if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) #define INDEX_END (-2) /* *---------------------------------------------------------------------- * * GetIndexFromToken -- * * Parse a token and get the encoded version of the index (as understood * by TEBC), assuming it is at all knowable at compile time. Only handles * indices that are integers or 'end' or 'end-integer'. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: * Sets *index to the index value if successful. * *---------------------------------------------------------------------- */ static inline int GetIndexFromToken( Tcl_Token *tokenPtr, int *index) { Tcl_Obj *tmpObj = Tcl_NewObj(); int result, idx; if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { Tcl_DecrRefCount(tmpObj); return TCL_ERROR; } result = TclGetIntFromObj(NULL, tmpObj, &idx); if (result == TCL_OK) { if (idx < 0) { result = TCL_ERROR; } } else { result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx); if (result == TCL_OK && idx > INDEX_END) { result = TCL_ERROR; } } Tcl_DecrRefCount(tmpObj); if (result == TCL_OK) { *index = idx; } return result; } /* *---------------------------------------------------------------------- * * 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, localIndex, numWords; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; } isAssignment = (numWords == 3); /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); /* * If we are doing an assignment, push the new value. */ if (isAssignment) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } /* * Emit instructions to set/get the variable. */ if (isScalar) { if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_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); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileString*Cmd -- * * Procedures called to compile various subcommands of the "string" * 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" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileStringCatCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { int i, numWords = parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; DefineLineInformation; /* TIP #280 */ /* Trivial case, no arg */ if (numWords<2) { PushStringLiteral(envPtr, ""); return TCL_OK; } /* General case: issue CONCAT1's (by chunks of 254 if needed), folding contiguous constants along the way */ numArgs = 0; folded = NULL; wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { obj = Tcl_NewObj(); if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { if (folded) { Tcl_AppendObjToObj(folded, obj); Tcl_DecrRefCount(obj); } else { folded = obj; } } else { Tcl_DecrRefCount(obj); if (folded) { int len; const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); folded = NULL; numArgs ++; } CompileWord(envPtr, wordTokenPtr, interp, i); numArgs ++; if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ TclEmitInstInt1(INST_STR_CONCAT1, 254, envPtr); numArgs -= 253; /* concat pushes 1 obj, the result */ } } wordTokenPtr = TokenAfter(wordTokenPtr); } if (folded) { int len; const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); folded = NULL; numArgs ++; } if (numArgs > 1) { TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); } return TCL_OK; } 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; } 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; } int TclCompileStringFirstCmd( 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); OP(STR_FIND); return TCL_OK; } int TclCompileStringLastCmd( 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); OP(STR_FIND_LAST); return TCL_OK; } 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; } int TclCompileStringIsCmd( 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 = TokenAfter(parsePtr->tokenPtr); static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", "boolean", "digit", "double", "entier", "false", "graph", "integer", "list", "lower", "print", "punct", "space", "true", "upper", "wideinteger", "wordchar", "xdigit", NULL }; enum isClasses { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT }; int t, range, allowEmpty = 0, end; InstStringClassType strClassType; Tcl_Obj *isClass; if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { return TCL_ERROR; } isClass = Tcl_NewObj(); if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) { Tcl_DecrRefCount(isClass); return TCL_ERROR; } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0, &t) != TCL_OK) { Tcl_DecrRefCount(isClass); TclCompileSyntaxError(interp, envPtr); return TCL_OK; } Tcl_DecrRefCount(isClass); #define GotLiteral(tokenPtr, word) \ ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \ (tokenPtr)[1].size > 1 && \ (tokenPtr)[1].start[0] == word[0] && \ strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) /* * Cannot handle the -failindex option at all, and that's the only legal * way to have more than 4 arguments. */ if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); if (parsePtr->numWords == 3) { allowEmpty = 1; } else { if (!GotLiteral(tokenPtr, "-strict")) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); } #undef GotLiteral /* * Compile the code. There are several main classes of check here. * 1. Character classes * 2. Booleans * 3. Integers * 4. Floats * 5. Lists */ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); switch ((enum isClasses) t) { case STR_IS_ALNUM: strClassType = STR_CLASS_ALNUM; goto compileStrClass; case STR_IS_ALPHA: strClassType = STR_CLASS_ALPHA; goto compileStrClass; case STR_IS_ASCII: strClassType = STR_CLASS_ASCII; goto compileStrClass; case STR_IS_CONTROL: strClassType = STR_CLASS_CONTROL; goto compileStrClass; case STR_IS_DIGIT: strClassType = STR_CLASS_DIGIT; goto compileStrClass; case STR_IS_GRAPH: strClassType = STR_CLASS_GRAPH; goto compileStrClass; case STR_IS_LOWER: strClassType = STR_CLASS_LOWER; goto compileStrClass; case STR_IS_PRINT: strClassType = STR_CLASS_PRINT; goto compileStrClass; case STR_IS_PUNCT: strClassType = STR_CLASS_PUNCT; goto compileStrClass; case STR_IS_SPACE: strClassType = STR_CLASS_SPACE; goto compileStrClass; case STR_IS_UPPER: strClassType = STR_CLASS_UPPER; goto compileStrClass; case STR_IS_WORD: strClassType = STR_CLASS_WORD; goto compileStrClass; case STR_IS_XDIGIT: strClassType = STR_CLASS_XDIGIT; compileStrClass: if (allowEmpty) { OP1( STR_CLASS, strClassType); } else { int over, over2; OP( DUP); OP1( STR_CLASS, strClassType); JUMP1( JUMP_TRUE, over); OP( POP); PUSH( "0"); JUMP1( JUMP, over2); FIXJUMP1(over); PUSH( ""); OP( STR_NEQ); FIXJUMP1(over2); } return TCL_OK; case STR_IS_BOOL: case STR_IS_FALSE: case STR_IS_TRUE: OP( TRY_CVT_TO_BOOLEAN); switch (t) { int over, over2; case STR_IS_BOOL: if (allowEmpty) { JUMP1( JUMP_TRUE, over); PUSH( ""); OP( STR_EQ); JUMP1( JUMP, over2); FIXJUMP1(over); OP( POP); PUSH( "1"); FIXJUMP1(over2); } else { OP4( REVERSE, 2); OP( POP); } return TCL_OK; case STR_IS_TRUE: JUMP1( JUMP_TRUE, over); if (allowEmpty) { PUSH( ""); OP( STR_EQ); } else { OP( POP); PUSH( "0"); } FIXJUMP1( over); OP( LNOT); OP( LNOT); return TCL_OK; case STR_IS_FALSE: JUMP1( JUMP_TRUE, over); if (allowEmpty) { PUSH( ""); OP( STR_NEQ); } else { OP( POP); PUSH( "1"); } FIXJUMP1( over); OP( LNOT); return TCL_OK; } case STR_IS_DOUBLE: { int satisfied, isEmpty; if (allowEmpty) { OP( DUP); PUSH( ""); OP( STR_EQ); JUMP1( JUMP_TRUE, isEmpty); OP( NUM_TYPE); JUMP1( JUMP_TRUE, satisfied); PUSH( "0"); JUMP1( JUMP, end); FIXJUMP1( isEmpty); OP( POP); FIXJUMP1( satisfied); } else { OP( NUM_TYPE); JUMP1( JUMP_TRUE, satisfied); PUSH( "0"); JUMP1( JUMP, end); TclAdjustStackDepth(-1, envPtr); FIXJUMP1( satisfied); } PUSH( "1"); FIXJUMP1( end); return TCL_OK; } case STR_IS_INT: case STR_IS_WIDE: case STR_IS_ENTIER: if (allowEmpty) { int testNumType; OP( DUP); OP( NUM_TYPE); OP( DUP); JUMP1( JUMP_TRUE, testNumType); OP( POP); PUSH( ""); OP( STR_EQ); JUMP1( JUMP, end); TclAdjustStackDepth(1, envPtr); FIXJUMP1( testNumType); OP4( REVERSE, 2); OP( POP); } else { OP( NUM_TYPE); OP( DUP); JUMP1( JUMP_FALSE, end); } switch (t) { case STR_IS_INT: PUSH( "1"); OP( EQ); break; case STR_IS_WIDE: PUSH( "2"); OP( LE); break; case STR_IS_ENTIER: PUSH( "3"); OP( LE); break; } FIXJUMP1( end); return TCL_OK; case STR_IS_LIST: range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); OP( DUP); OP( LIST_LENGTH); OP( POP); ExceptionRangeEnds(envPtr, range); ExceptionRangeTarget(envPtr, range, catchOffset); OP( POP); OP( PUSH_RETURN_CODE); OP( END_CATCH); OP( LNOT); return TCL_OK; } return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } 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 TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } 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 TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } nocase = 1; tokenPtr = TokenAfter(tokenPtr); } /* * Push the strings to match against each other. */ for (i = 0; i < 2; i++) { if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { str = tokenPtr[1].start; length = tokenPtr[1].size; if (!nocase && (i == 0)) { /* * Trivial matches can be done by 'string equal'. If -nocase * was specified, we can't do this because INST_STR_EQ has no * support for nocase. */ Tcl_Obj *copy = Tcl_NewStringObj(str, length); Tcl_IncrRefCount(copy); exactMatch = TclMatchIsTrivial(TclGetString(copy)); TclDecrRefCount(copy); } PushLiteral(envPtr, str, length); } else { SetLineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); } /* * Push the matcher. */ if (exactMatch) { TclEmitOpcode(INST_STR_EQ, envPtr); } else { TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); } return TCL_OK; } int TclCompileStringLenCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; Tcl_Obj *objPtr; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(objPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { /* * Here someone is asking for the length of a static string (or * something with backslashes). Just push the actual character (not * byte) length. */ char buf[TCL_INTEGER_SPACE]; int len = Tcl_GetCharLength(objPtr); len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { SetLineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } TclDecrRefCount(objPtr); return TCL_OK; } int TclCompileStringMapCmd( 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 *mapTokenPtr, *stringTokenPtr; Tcl_Obj *mapObj, **objv; char *bytes; int len; /* * We only handle the case: * * string map {foo bar} $thing * * That is, a literal two-element list (doesn't need to be brace-quoted, * but does need to be compile-time knowable) and any old argument (the * thing to map). */ if (parsePtr->numWords != 3) { return TCL_ERROR; } mapTokenPtr = TokenAfter(parsePtr->tokenPtr); stringTokenPtr = TokenAfter(mapTokenPtr); mapObj = Tcl_NewObj(); Tcl_IncrRefCount(mapObj); if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (len != 2) { Tcl_DecrRefCount(mapObj); return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* * Now issue the opcodes. Note that in the case that we know that the * first word is an empty word, we don't issue the map at all. That is the * correct semantics for mapping. */ bytes = Tcl_GetStringFromObj(objv[0], &len); if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { PushLiteral(envPtr, bytes, len); bytes = Tcl_GetStringFromObj(objv[1], &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); } Tcl_DecrRefCount(mapObj); return TCL_OK; } int TclCompileStringRangeCmd( 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 *stringTokenPtr, *fromTokenPtr, *toTokenPtr; int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; } stringTokenPtr = TokenAfter(parsePtr->tokenPtr); fromTokenPtr = TokenAfter(stringTokenPtr); toTokenPtr = TokenAfter(fromTokenPtr); /* * Parse the two indices. */ if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) { goto nonConstantIndices; } if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) { goto nonConstantIndices; } /* * Push the operand onto the stack and then the substring operation. */ CompileWord(envPtr, stringTokenPtr, interp, 1); OP44( STR_RANGE_IMM, idx1, idx2); return TCL_OK; /* * Push the operands onto the stack and then the substring operation. */ nonConstantIndices: CompileWord(envPtr, stringTokenPtr, interp, 1); CompileWord(envPtr, fromTokenPtr, interp, 2); CompileWord(envPtr, toTokenPtr, interp, 3); OP( STR_RANGE); return TCL_OK; } int TclCompileStringReplaceCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ 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 *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL; DefineLineInformation; /* TIP #280 */ int idx1, idx2; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } valueTokenPtr = TokenAfter(parsePtr->tokenPtr); if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(valueTokenPtr); tokenPtr = TokenAfter(tokenPtr); replacementTokenPtr = TokenAfter(tokenPtr); } /* * Parse the indices. Will only compile special cases if both are * constants and not an _integer_ less than zero (since we reserve * negative indices here for end-relative indexing) or an end-based index * greater than 'end' itself. */ tokenPtr = TokenAfter(valueTokenPtr); if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { goto genericReplace; } tokenPtr = TokenAfter(tokenPtr); if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { goto genericReplace; } /* * We handle these replacements specially: first character (where * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything * else and the semantics get rather screwy. */ if (idx1 == 0 && idx2 == 0) { int notEq, end; /* * Just working with the first character. */ CompileWord(envPtr, valueTokenPtr, interp, 1); if (replacementTokenPtr == NULL) { /* Drop first */ OP44( STR_RANGE_IMM, 1, INDEX_END); return TCL_OK; } /* Replace first */ CompileWord(envPtr, replacementTokenPtr, interp, 4); OP4( OVER, 1); PUSH( ""); OP( STR_EQ); JUMP1( JUMP_FALSE, notEq); OP( POP); JUMP1( JUMP, end); FIXJUMP1(notEq); TclAdjustStackDepth(1, envPtr); OP4( REVERSE, 2); OP44( STR_RANGE_IMM, 1, INDEX_END); OP1( STR_CONCAT1, 2); FIXJUMP1(end); return TCL_OK; } else if (idx1 == INDEX_END && idx2 == INDEX_END) { int notEq, end; /* * Just working with the last character. */ CompileWord(envPtr, valueTokenPtr, interp, 1); if (replacementTokenPtr == NULL) { /* Drop last */ OP44( STR_RANGE_IMM, 0, INDEX_END-1); return TCL_OK; } /* Replace last */ CompileWord(envPtr, replacementTokenPtr, interp, 4); OP4( OVER, 1); PUSH( ""); OP( STR_EQ); JUMP1( JUMP_FALSE, notEq); OP( POP); JUMP1( JUMP, end); FIXJUMP1(notEq); TclAdjustStackDepth(1, envPtr); OP4( REVERSE, 2); OP44( STR_RANGE_IMM, 0, INDEX_END-1); OP4( REVERSE, 2); OP1( STR_CONCAT1, 2); FIXJUMP1(end); return TCL_OK; } else { /* * Need to process indices at runtime. This could be because the * indices are not constants, or because we need to resolve them to * absolute indices to work out if a replacement is going to happen. * In any case, to runtime it is. */ genericReplace: CompileWord(envPtr, valueTokenPtr, interp, 1); tokenPtr = TokenAfter(valueTokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); if (replacementTokenPtr != NULL) { CompileWord(envPtr, replacementTokenPtr, interp, 4); } else { PUSH( ""); } OP( STR_REPLACE); return TCL_OK; } } int TclCompileStringTrimLCmd( 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 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM_LEFT); return TCL_OK; } int TclCompileStringTrimRCmd( 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 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM_RIGHT); return TCL_OK; } int TclCompileStringTrimCmd( 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 && parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM); return TCL_OK; } int TclCompileStringToUpperCmd( 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 TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); OP( STR_UPPER); return TCL_OK; } int TclCompileStringToLowerCmd( 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 TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); OP( STR_LOWER); return TCL_OK; } int TclCompileStringToTitleCmd( 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 TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); OP( STR_TITLE); return TCL_OK; } /* * Support definitions for the [string is] compilation. */ static int UniCharIsAscii( int character) { return (character >= 0) && (character < 0x80); } static int UniCharIsHexDigit( int character) { return (character >= 0) && (character < 0x80) && isxdigit(character); } StringClassDesc const tclStringClassTable[] = { {"alnum", Tcl_UniCharIsAlnum}, {"alpha", Tcl_UniCharIsAlpha}, {"ascii", UniCharIsAscii}, {"control", Tcl_UniCharIsControl}, {"digit", Tcl_UniCharIsDigit}, {"graph", Tcl_UniCharIsGraph}, {"lower", Tcl_UniCharIsLower}, {"print", Tcl_UniCharIsPrint}, {"punct", Tcl_UniCharIsPunct}, {"space", Tcl_UniCharIsSpace}, {"upper", Tcl_UniCharIsUpper}, {"word", Tcl_UniCharIsWordChar}, {"xdigit", UniCharIsHexDigit}, {NULL, NULL} }; /* *---------------------------------------------------------------------- * * TclCompileSubstCmd -- * * Procedure called to compile the "subst" command. * * Results: * Returns TCL_OK for successful compile, or TCL_ERROR to defer * evaluation to runtime (either when it is too complex to get the * semantics right, or when we know for sure that it is an error but need * the error to happen at the right time). * * Side effects: * Instructions are added to envPtr to execute the "subst" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileSubstCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { int numArgs = parsePtr->numWords - 1; int numOpts = numArgs - 1; int objc, flags = TCL_SUBST_ALL; Tcl_Obj **objv/*, *toSubst = NULL*/; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); int code = TCL_ERROR; DefineLineInformation; /* TIP #280 */ if (numArgs == 0) { return TCL_ERROR; } objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { objv[objc] = Tcl_NewObj(); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; goto cleanup; } wordTokenPtr = TokenAfter(wordTokenPtr); } /* if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) { toSubst = objv[numOpts]; Tcl_IncrRefCount(toSubst); } */ /* TODO: Figure out expansion to cover WordKnownAtCompileTime * The difficulty is that WKACT makes a copy, and if TclSubstParse * below parses the copy of the original source string, some deep * parts of the compile machinery get upset. They want all pointers * stored in Tcl_Tokens to point back to the same original string. */ if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { code = TclSubstOptions(NULL, numOpts, objv, &flags); } cleanup: while (--objc >= 0) { TclDecrRefCount(objv[objc]); } TclStackFree(interp, objv); if (/*toSubst == NULL*/ code != TCL_OK) { return TCL_ERROR; } SetLineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); /* TclDecrRefCount(toSubst);*/ return TCL_OK; } void TclSubstCompile( Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; int breakOffset = 0, count = 0, bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); if (state != NULL) { Tcl_ResetResult(interp); } /* * Tricky point! If the first token does not result in a *guaranteed* push * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for * identifying a script that could trigger this case. */ tokenPtr = parse.tokenPtr; if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) { PUSH(""); count++; } for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { int length, literal, catchRange, breakJump; char buf[TCL_UTF_MAX]; JumpFixup startFixup, okFixup, returnFixup, breakFixup; JumpFixup continueFixup, otherFixup, endFixup; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: literal = TclRegisterNewLiteral(envPtr, tokenPtr->start, tokenPtr->size); TclEmitPush(literal, envPtr); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); count++; continue; case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); literal = TclRegisterNewLiteral(envPtr, buf, length); TclEmitPush(literal, envPtr); count++; continue; case TCL_TOKEN_VARIABLE: /* * Check for simple variable access; see if we can only generate * TCL_OK or TCL_ERROR from the substituted variable read; if so, * there is no need to generate elaborate exception-management * code. Note that the first component of TCL_TOKEN_VARIABLE is * always TCL_TOKEN_TEXT... */ if (tokenPtr->numComponents > 1) { int i, foundCommand = 0; for (i=2 ; i<=tokenPtr->numComponents ; i++) { if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { foundCommand = 1; break; } } if (foundCommand) { break; } } envPtr->line = bline; TclCompileVarSubst(interp, tokenPtr, envPtr); bline = envPtr->line; count++; continue; } while (count > 255) { OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { OP1( STR_CONCAT1, count); count = 1; } if (breakOffset == 0) { /* Jump to the start (jump over the jump to end) */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); /* Jump to the end (all BREAKs land here) */ breakOffset = CurrentOffset(envPtr); TclEmitInstInt4(INST_JUMP4, 0, envPtr); /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); } } envPtr->line = bline; catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, catchRange); ExceptionRangeStarts(envPtr, catchRange); switch (tokenPtr->type) { case TCL_TOKEN_COMMAND: TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); count++; break; case TCL_TOKEN_VARIABLE: TclCompileVarSubst(interp, tokenPtr, envPtr); count++; break; default: Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", tokenPtr->type); } ExceptionRangeEnds(envPtr, catchRange); /* Substitution produced TCL_OK */ OP( END_CATCH); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); TclAdjustStackDepth(-1, envPtr); /* Exceptional return codes processed here */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); OP( PUSH_RETURN_CODE); OP( END_CATCH); OP( RETURN_CODE_BRANCH); /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ OP( RETURN_STK); OP( NOP); /* RETURN */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); /* BREAK */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); /* CONTINUE */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); /* OTHER */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); } OP( POP); OP( POP); breakJump = CurrentOffset(envPtr) - breakOffset; if (breakJump > 127) { OP4(JUMP4, -breakJump); } else { OP1(JUMP1, -breakJump); } TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); } OP( POP); OP( POP); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); } /* * Pull the result to top of stack, discard options dict. */ OP4( REVERSE, 2); OP( POP); /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { OP1(STR_CONCAT1, count); count = 1; } /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); } bline = envPtr->line; } while (count > 255) { OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { OP1( STR_CONCAT1, count); } Tcl_FreeParse(&parse); if (state != NULL) { Tcl_RestoreInterpState(interp, state); TclCompileSyntaxError(interp, envPtr); TclAdjustStackDepth(-1, envPtr); } /* Final target of the multi-jump from all BREAKs */ if (breakOffset > 0) { TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, envPtr->codeStart + breakOffset); } } /* *---------------------------------------------------------------------- * * TclCompileSwitchCmd -- * * Procedure called to compile the "switch" command. * * Results: * Returns TCL_OK for successful compile, or TCL_ERROR to defer * evaluation to runtime (either when it is too complex to get the * semantics right, or when we know for sure that it is an error but need * the error to happen at the right time). * * Side effects: * Instructions are added to envPtr to execute the "switch" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileSwitchCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; /* Pointer to tokens in command. */ int numWords; /* Number of words in command. */ Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; /* What kind of switch are we doing? */ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ int *bodyLines; /* Array of line numbers for body list * items. */ int **bodyContLines; /* Array of continuation line info. */ int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ int i, valueIndex; int result = TCL_ERROR; DefineLineInformation; /* TIP #280 */ int *clNext = envPtr->clNext; /* * Only handle the following versions: * switch ?--? word {pattern body ...} * switch -exact ?--? word {pattern body ...} * switch -glob ?--? word {pattern body ...} * switch -regexp ?--? word {pattern body ...} * switch -- word simpleWordPattern simpleWordBody ... * switch -exact -- word simpleWordPattern simpleWordBody ... * switch -glob -- word simpleWordPattern simpleWordBody ... * switch -regexp -- word simpleWordPattern simpleWordBody ... * When the mode is -glob, can also handle a -nocase flag. * * First off, we don't care how the command's word was generated; we're * compiling it anyway! So skip it... */ tokenPtr = TokenAfter(parsePtr->tokenPtr); valueIndex = 1; numWords = parsePtr->numWords-1; /* * Check for options. */ noCase = 0; mode = Switch_Exact; if (numWords == 2) { /* * There's just the switch value and the bodies list. In that case, we * can skip all option parsing and move on to consider switch values * and the body list. */ goto finishedOptionParse; } /* * There must be at least one option, --, because without that there is no * way to statically avoid the problems you get from strings-to-be-matched * that start with a - (the interpreted code falls apart if it encounters * them, so we punt if we *might* encounter them as that is the easiest * way of emulating the behaviour). */ for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { register unsigned size = tokenPtr[1].size; register const char *chrs = tokenPtr[1].start; /* * 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) { const char *bytes; int maxLen, numBytes; int bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } bytes = tokenPtr[1].start; numBytes = tokenPtr[1].size; /* Allocate enough space to work in. */ maxLen = TclMaxListLength(bytes, numBytes, NULL); if (maxLen < 2) { return TCL_ERROR; } bodyTokenArray = ckalloc(sizeof(Tcl_Token) * maxLen); bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen); bodyLines = ckalloc(sizeof(int) * maxLen); bodyContLines = ckalloc(sizeof(int*) * maxLen); bline = mapPtr->loc[eclIndex].line[valueIndex+1]; numWords = 0; while (numBytes > 0) { const char *prevBytes = bytes; int literal; if (TCL_OK != TclFindElement(NULL, bytes, numBytes, &(bodyTokenArray[numWords].start), &bytes, &(bodyTokenArray[numWords].size), &literal) || !literal) { goto abort; } bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; bodyTokenArray[numWords].numComponents = 0; bodyToken[numWords] = bodyTokenArray + numWords; /* * TIP #280: Now determine the line the list element starts on * (there is no need to do it earlier, due to the possibility of * aborting, see above). */ TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start); TclAdvanceContinuations(&bline, &clNext, bodyTokenArray[numWords].start - envPtr->source); bodyLines[numWords] = bline; bodyContLines[numWords] = clNext; TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source); numBytes -= (bytes - prevBytes); numWords++; } if (numWords % 2) { abort: ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); ckfree((char *) bodyContLines); 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 = ckalloc(sizeof(Tcl_Token *) * numWords); bodyLines = ckalloc(sizeof(int) * numWords); bodyContLines = ckalloc(sizeof(int*) * numWords); bodyTokenArray = NULL; for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { goto freeTemporaries; } bodyToken[i] = tokenPtr+1; /* * TIP #280: Copy line information from regular cmd info. */ bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; tokenPtr = TokenAfter(tokenPtr); } } /* * Fall back to interpreted if the last body is a continuation (it's * illegal, but this makes the error happen at the right time). */ if (bodyToken[numWords-1]->size == 1 && bodyToken[numWords-1]->start[0] == '-') { goto freeTemporaries; } /* * Now we commit to generating code; the parsing stage per se is done. * Check if we can generate a jump table, since if so that's faster than * doing an explicit compare with each body. Note that we're definitely * over-conservative with determining whether we can do the jump table, * but it handles the most common case well enough. */ /* Both methods push the value to match against onto the stack. */ CompileWord(envPtr, valueTokenPtr, interp, valueIndex); if (mode == Switch_Exact) { IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, bodyLines, bodyContLines); } else { IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex, numWords, bodyToken, bodyLines, bodyContLines); } result = TCL_OK; /* * Clean up all our temporary space and return. */ freeTemporaries: ckfree(bodyToken); ckfree(bodyLines); ckfree(bodyContLines); if (bodyTokenArray != NULL) { ckfree(bodyTokenArray); } return result; } /* *---------------------------------------------------------------------- * * IssueSwitchChainedTests -- * * Generate instructions for a [switch] command that is to be compiled * into a sequence of tests. This is the generic handle-everything mode * that inherently has performance that is (on average) linear in the * number of tests. It is the only mode that can handle -glob and -regexp * matches, or anything that is case-insensitive. It does not handle the * wild-and-wooly end of regexp matching (i.e., capture of match results) * so that's when we spill to the interpreted version. * *---------------------------------------------------------------------- */ static void IssueSwitchChainedTests( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ int valueIndex, /* The value to match against. */ int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ int *bodyLines, /* Array of line numbers for body list * items. */ int **bodyContLines) /* Array of continuation line info. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ int contFixIndex; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if * there aren't any. */ int contFixCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ int nextArmFixupIndex; int simple, exact; /* For extracting the type of regexp. */ int i; /* * Generate a test for each arm. */ contFixIndex = -1; contFixCount = 0; fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens); fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens); memset(fixupTargetArray, 0, numBodyTokens * sizeof(int)); fixupCount = 0; foundDefault = 0; for (i=0 ; isize != 7 || memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { /* * Generate the test for the arm. */ switch (mode) { case Switch_Exact: OP( DUP); TclCompileTokens(interp, bodyToken[i], 1, envPtr); OP( STR_EQ); break; case Switch_Glob: TclCompileTokens(interp, bodyToken[i], 1, envPtr); OP4( OVER, 1); OP1( STR_MATCH, noCase); break; case Switch_Regexp: simple = exact = 0; /* * Keep in sync with TclCompileRegexpCmd. */ if (bodyToken[i]->type == TCL_TOKEN_TEXT) { Tcl_DString ds; if (bodyToken[i]->size == 0) { /* * The semantics of regexps are that they always match * when the RE == "". */ PUSH("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, NULL) == TCL_OK){ simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } } if (!simple) { TclCompileTokens(interp, bodyToken[i], 1, envPtr); } OP4( OVER, 1); if (!simple) { /* * Pass correct RE compile flags. We use only Int1 * (8-bit), but that handles all the flags we want to * pass. Don't use TCL_REG_NOSUB as we may have backrefs * or capture vars. */ int cflags = TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0); OP1(REGEXP, cflags); } else if (exact && !noCase) { OP( STR_EQ); } else { OP1(STR_MATCH, noCase); } 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 ; jline = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); if (!foundDefault) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &fixupArray[fixupCount]); fixupCount++; fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); } } /* * Discard the value we are matching against unless we've had a default * clause (in which case it will already be gone due to the code at the * start of processing an arm, guaranteed) and make the result of the * command an empty string. */ if (!foundDefault) { OP( POP); PUSH(""); } /* * 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 ; icodeNext-envPtr->codeStart; } } /* * Now scan backwards over all the jumps (all of which are forward jumps) * doing each one. When we do one and there is a size changes, we must * scan back over all the previous ones and see if they need adjusting * before proceeding with further jump fixups (the interleaved nature of * all the jumps makes this impossible to do without nested loops). */ for (i=fixupCount-1 ; i>=0 ; i--) { if (TclFixupForwardJump(envPtr, &fixupArray[i], fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { int j; for (j=i-1 ; j>=0 ; j--) { if (fixupTargetArray[j] > fixupArray[i].codeOffset) { fixupTargetArray[j] += 3; } } } } TclStackFree(interp, fixupTargetArray); TclStackFree(interp, fixupArray); } /* *---------------------------------------------------------------------- * * IssueSwitchJumpTable -- * * Generate instructions for a [switch] command that is to be compiled * into a jump table. This only handles the case where case-sensitive, * exact matching is used, but this is actually the most common case in * real code. * *---------------------------------------------------------------------- */ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int valueIndex, /* The value to match against. */ int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ int *bodyLines, /* Array of line numbers for body list * items. */ int **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, foundDefault, jumpToDefault, i; Tcl_DString buffer; Tcl_HashEntry *hPtr; /* * 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 = ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); foundDefault = 0; mustGenerate = 1; /* * Next, issue the instruction to do the jump, together with what we want * to do if things do not work out (jump to either the default clause or * the "default" default, which just sets the result to empty). Note that * we will come back and rewrite the jump's offset parameter when we know * what it should be, and that all jumps we issue are of the wide kind * because that makes the code much easier to debug! */ jumpLocation = CurrentOffset(envPtr); OP4( JUMP_TABLE, infoIndex); jumpToDefault = CurrentOffset(envPtr); OP4( JUMP4, 0); for (i=0 ; isize != 7 || memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { /* * This is not a default clause, so insert the current location as * a target in the jump table (assuming it isn't already there, * which would indicate that this clause is probably masked by an * earlier one). Note that we use a Tcl_DString here simply * because the hash API does not let us specify the string length. */ Tcl_DStringInit(&buffer); TclDStringAppendToken(&buffer, bodyToken[i]); hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, Tcl_DStringValue(&buffer), &isNew); if (isNew) { /* * First time we've encountered this match clause, so it must * point to here. */ Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation); } Tcl_DStringFree(&buffer); } else { /* * This is a default clause, so patch up the fallthrough from the * INST_JUMP_TABLE instruction to here. */ foundDefault = 1; isNew = 1; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); } /* * Now, for each arm we must deal with the body of the clause. * * If this is a continuation body (never true of a final clause, * whether default or not) we're done because the next jump target * will also point here, so we advance to the next clause. */ if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { mustGenerate = 1; continue; } /* * Also skip this arm if its only match clause is masked. (We could * probably be more aggressive about this, but that would be much more * difficult to get right.) */ if (!isNew && !mustGenerate) { continue; } mustGenerate = 0; /* * Compile the body of the arm. */ envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); /* * Compile a jump in to the end of the command if this body is * anything other than a user-supplied default arm (to either skip * over the remaining bodies or the code that generates an empty * result). */ if (i+2 < numBodyTokens || !foundDefault) { finalFixups[numRealBodies++] = CurrentOffset(envPtr); /* * Easier by far to issue this jump as a fixed-width jump, since * otherwise we'd need to do a lot more (and more awkward) * rewriting when we fixed this all up. */ OP4( JUMP4, 0); TclAdjustStackDepth(-1, 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); PUSH(""); } /* * 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 ; icodeStart+finalFixups[i]+1); } /* * Clean up all our temporary space and return. */ TclStackFree(interp, finalFixups); } /* *---------------------------------------------------------------------- * * DupJumptableInfo, FreeJumptableInfo -- * * Functions to duplicate, release and print a jump-table created for use * with the INST_JUMP_TABLE instruction. * * Results: * DupJumptableInfo: a copy of the jump-table * FreeJumptableInfo: none * PrintJumptableInfo: none * * Side effects: * DupJumptableInfo: allocates memory * FreeJumptableInfo: releases memory * PrintJumptableInfo: none * *---------------------------------------------------------------------- */ static ClientData DupJumptableInfo( ClientData clientData) { JumptableInfo *jtPtr = clientData; JumptableInfo *newJtPtr = 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(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); } } /* *---------------------------------------------------------------------- * * TclCompileTailcallCmd -- * * Procedure called to compile the "tailcall" 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 "tailcall" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileTailcallCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; if (parsePtr->numWords < 2 || parsePtr->numWords > 256 || envPtr->procPtr == NULL) { return TCL_ERROR; } /* make room for the nsObjPtr */ /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileThrowCmd -- * * Procedure called to compile the "throw" 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 "throw" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileThrowCmd( 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 */ int numWords = parsePtr->numWords; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; int codeKnown, codeIsList, codeIsValid, len; if (numWords != 3) { return TCL_ERROR; } codeToken = TokenAfter(parsePtr->tokenPtr); msgToken = TokenAfter(codeToken); TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); codeKnown = TclWordKnownAtCompileTime(codeToken, objPtr); /* * First we must emit the code to substitute the arguments. This * must come first in case substitution raises errors. */ if (!codeKnown) { CompileWord(envPtr, codeToken, interp, 1); PUSH( "-errorcode"); } CompileWord(envPtr, msgToken, interp, 2); codeIsList = codeKnown && (TCL_OK == Tcl_ListObjLength(interp, objPtr, &len)); codeIsValid = codeIsList && (len != 0); if (codeIsValid) { Tcl_Obj *errPtr, *dictPtr; TclNewLiteralStringObj(errPtr, "-errorcode"); TclNewObj(dictPtr); Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr); TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr); } TclDecrRefCount(objPtr); /* * Simpler bytecodes when we detect invalid arguments at compile time. */ if (codeKnown && !codeIsValid) { OP( POP); if (codeIsList) { /* Must be an empty list */ goto issueErrorForEmptyCode; } TclCompileSyntaxError(interp, envPtr); return TCL_OK; } if (!codeKnown) { /* * Argument validity checking has to be done by bytecode at * run time. */ OP4( REVERSE, 3); OP( DUP); OP( LIST_LENGTH); OP1( JUMP_FALSE1, 16); OP4( LIST, 2); OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); OP( POP); OP( POP); OP( POP); issueErrorForEmptyCode: PUSH( "type must be non-empty list"); PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}"); } OP44( RETURN_IMM, TCL_ERROR, 0); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileTryCmd -- * * Procedure called to compile the "try" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "try" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileTryCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR; Tcl_Token *bodyToken, *finallyToken, *tokenPtr; Tcl_Token **handlerTokens = NULL; Tcl_Obj **matchClauses = NULL; int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL; int i; if (numWords < 2) { return TCL_ERROR; } bodyToken = TokenAfter(parsePtr->tokenPtr); if (numWords == 2) { /* * No handlers or finally; do nothing beyond evaluating the body. */ DefineLineInformation; /* TIP #280 */ BODY(bodyToken, 1); return TCL_OK; } numWords -= 2; tokenPtr = TokenAfter(bodyToken); /* * Extract information about what handlers there are. */ numHandlers = numWords >> 2; numWords -= numHandlers * 4; if (numHandlers > 0) { handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers); matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers); memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers); matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers); resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; } if (tokenPtr[1].size == 4 && !strncmp(tokenPtr[1].start, "trap", 4)) { /* * Parse the list of errorCode words to match against. */ matchCodes[i] = TCL_ERROR; tokenPtr = TokenAfter(tokenPtr); TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK || (objc == 0)) { TclDecrRefCount(tmpObj); goto failedToCompile; } Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL); matchClauses[i] = tmpObj; } else if (tokenPtr[1].size == 2 && !strncmp(tokenPtr[1].start, "on", 2)) { int code; /* * Parse the result code to look for. */ tokenPtr = TokenAfter(tokenPtr); TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { TclDecrRefCount(tmpObj); goto failedToCompile; } if (TCL_ERROR == TclGetCompletionCodeFromObj(NULL, tmpObj, &code)) { TclDecrRefCount(tmpObj); goto failedToCompile; } matchCodes[i] = code; TclDecrRefCount(tmpObj); } else { goto failedToCompile; } /* * Parse the variable binding. */ tokenPtr = TokenAfter(tokenPtr); TclNewObj(tmpObj); Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { TclDecrRefCount(tmpObj); goto failedToCompile; } if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK || (objc > 2)) { TclDecrRefCount(tmpObj); goto failedToCompile; } if (objc > 0) { int len; const char *varname = Tcl_GetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; } } else { resultVarIndices[i] = -1; } if (objc == 2) { int len; const char *varname = Tcl_GetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; } } else { optionVarIndices[i] = -1; } TclDecrRefCount(tmpObj); /* * Extract the body for this handler. */ tokenPtr = TokenAfter(tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; } if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') { handlerTokens[i] = NULL; } else { handlerTokens[i] = tokenPtr; } tokenPtr = TokenAfter(tokenPtr); } if (handlerTokens[numHandlers-1] == NULL) { goto failedToCompile; } } /* * Parse the finally clause */ if (numWords == 0) { finallyToken = NULL; } else if (numWords == 2) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7 || strncmp(tokenPtr[1].start, "finally", 7)) { goto failedToCompile; } finallyToken = TokenAfter(tokenPtr); } else { goto failedToCompile; } /* * Issue the bytecode. */ if (!finallyToken) { result = IssueTryClausesInstructions(interp, envPtr, bodyToken, numHandlers, matchCodes, matchClauses, resultVarIndices, optionVarIndices, handlerTokens); } else if (numHandlers == 0) { result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, finallyToken); } else { result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken, numHandlers, matchCodes, matchClauses, resultVarIndices, optionVarIndices, handlerTokens, finallyToken); } /* * Delete any temporary state and finish off. */ failedToCompile: if (numHandlers > 0) { for (i=0 ; i= 0) { LOAD( resultVar); STORE( resultVars[i]); OP( POP); if (optionVars[i] >= 0) { LOAD( optionsVar); STORE( optionVars[i]); OP( POP); } } if (!handlerTokens[i]) { forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); } else { int dontChangeOptions; forwardsToFix[i] = -1; if (forwardsNeedFixing) { forwardsNeedFixing = 0; for (j=0 ; j= 0 || handlerTokens[i]) { range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); } if (resultVars[i] >= 0) { LOAD( resultVar); STORE( resultVars[i]); OP( POP); if (optionVars[i] >= 0) { LOAD( optionsVar); STORE( optionVars[i]); OP( POP); } if (!handlerTokens[i]) { /* * No handler. Will not be the last handler (that is a * condition that is checked by the caller). Chain to the next * one. */ ExceptionRangeEnds(envPtr, range); OP( END_CATCH); forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); goto finishTrapCatchHandling; } } else if (!handlerTokens[i]) { /* * No handler. Will not be the last handler (that condition is * checked by the caller). Chain to the next one. */ forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); goto endOfThisArm; } /* * Got a handler. Make sure that any pending patch-up actions from * previous unprocessed handlers are dealt with now that we know where * they are to jump to. */ if (forwardsNeedFixing) { forwardsNeedFixing = 0; OP1( JUMP1, 7); for (j=0 ; jtokenPtr ; inumWords ; i++) { Tcl_Obj *leadingWord = Tcl_NewObj(); varTokenPtr = TokenAfter(varTokenPtr); if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { TclDecrRefCount(leadingWord); /* * We can tolerate non-trivial substitutions in the first variable * to be unset. If a '--' or '-nocomplain' was present, anything * goes in that one place! (All subsequent variable names must be * constants since we don't want to have to push them all first.) */ if (varCount == 0) { if (haveFlags) { continue; } /* * In fact, we're OK as long as we're the first argument *and* * we provably don't start with a '-'. If that is true, then * even if everything else is varying, we still can't be a * flag. Otherwise we'll spill to runtime to place a limit on * the trickiness. */ if (varTokenPtr->type == TCL_TOKEN_WORD && varTokenPtr[1].type == TCL_TOKEN_TEXT && varTokenPtr[1].size > 0 && varTokenPtr[1].start[0] != '-') { continue; } } return TCL_ERROR; } if (i == 1) { const char *bytes; int len; bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags = 1; } else if (len == 2 && !strncmp("--", bytes, 2)) { haveFlags = 1; } else { varCount++; } } else { varCount++; } TclDecrRefCount(leadingWord); } /* * Issue instructions to unset each of the named variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); if (haveFlags) { varTokenPtr = TokenAfter(varTokenPtr); } for (i=1+haveFlags ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include * namespace qualifiers. */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. */ if (isScalar) { if (localIndex < 0) { OP1( UNSET_STK, flags); } else { OP14( UNSET_SCALAR, flags, localIndex); } } else { if (localIndex < 0) { OP1( UNSET_ARRAY_STK, flags); } else { OP14( UNSET_ARRAY, flags, localIndex); } } varTokenPtr = TokenAfter(varTokenPtr); } PUSH(""); return TCL_OK; } /* *---------------------------------------------------------------------- * * 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 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 = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * 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 &= ~1; testCodeOffset = CurrentOffset(envPtr); } /* * Compile the loop body. */ bodyCodeOffset = ExceptionRangeStarts(envPtr, range); if (!loopMayEnd) { envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; } BODY(bodyTokenPtr, 2); ExceptionRangeEnds(envPtr, range); OP( POP); /* * 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; } SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); TclClearNumConversion(envPtr); 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); TclFinalizeLoopExceptionRange(envPtr, range); /* * The while command's result is an empty string. */ pushResult: PUSH(""); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileYieldCmd -- * * Procedure called to compile the "yield" 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 "yield" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileYieldCmd( 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 || parsePtr->numWords > 2) { return TCL_ERROR; } if (parsePtr->numWords == 1) { PUSH(""); } else { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 1); } OP( YIELD); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileYieldToCmd -- * * Procedure called to compile the "yieldto" 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 "yieldto" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileYieldToCmd( 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 = TokenAfter(parsePtr->tokenPtr); int i; if (parsePtr->numWords < 2) { return TCL_ERROR; } OP( NS_CURRENT); for (i = 1 ; i < parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } OP4( LIST, i); OP( YIELD_TO_INVOKE); 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; /* TODO: Consider support for compiling expanded args. */ for (words=1 ; wordsnumWords ; 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. */ OP4( REVERSE, words-1); } 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 */ /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { PUSH("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 = AnonymousLocal(envPtr); int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); STORE(tmpIndex); TclEmitOpcode(instruction, envPtr); for (words=3 ; wordsnumWords ;) { LOAD(tmpIndex); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { STORE(tmpIndex); } TclEmitOpcode(instruction, envPtr); } for (; words>3 ; words--) { OP( BITAND); } /* * Drop the value from the temp variable; retaining that reference * might be expensive elsewhere. */ OP14( UNSET_SCALAR, 0, tmpIndex); } 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 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); } if (parsePtr->numWords <= 2) { PUSH("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; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ return TCL_ERROR; } for (words=1 ; wordsnumWords ; 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; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. */ return TCL_ERROR; } if (parsePtr->numWords == 2) { PUSH("1.0"); } for (words=1 ; wordsnumWords ; 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; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */