diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclBasic.c | 2 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 113 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 |
4 files changed, 123 insertions, 7 deletions
@@ -1,8 +1,14 @@ 2012-02-15 Donal K. Fellows <dkf@users.sf.net> - * generic/tclCompCmds.c (TclCompileDictForCmd): [Bug 3487626]: Fix - crash in compilation of [dict for] when its implementation command is - used directly rather than through the ensemble. + * generic/tclCompCmds.c (TclCompileLrangeCmd): Add compiler for + [lrange] with constant indices so we can take advantage of existing + TCL_LIST_RANGE_IMM opcode. + (TclCompileLindexCmd): Improve coverage of constant-index-style + compliation using technique developed for [lrange] above. + + (TclCompileDictForCmd): [Bug 3487626]: Fix crash in compilation of + [dict for] when its implementation command is used directly rather + than through the ensemble. 2012-02-09 Don Porter <dgp@users.sourceforge.net> diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0365966..d67153c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -230,7 +230,7 @@ static const CmdInfo builtInCmds[] = { {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, - {"lrange", Tcl_LrangeObjCmd, NULL, NULL, 1}, + {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, {"lreplace", Tcl_LreplaceObjCmd, NULL, NULL, 1}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 18ff3dc..c96f05c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3147,13 +3147,24 @@ TclCompileLindexCmd( tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); + if (result == TCL_OK && idx > -2) { + result = TCL_ERROR; + } + } TclDecrRefCount(tmpObj); - if (result == TCL_OK && idx >= 0) { + if (result == TCL_OK) { /* - * All checks have been completed, and we have exactly this - * construct: + * All checks have been completed, and we have exactly one of + * these constructs: * lindex <arbitraryValue> <posInt> + * lindex <arbitraryValue> end-<posInt> * This is best compiled as a push of the arbitrary value followed * by an "immediate lindex" which is the most efficient variety. */ @@ -3298,6 +3309,102 @@ TclCompileLlengthCmd( /* *---------------------------------------------------------------------- * + * TclCompileLrangeCmd -- + * + * How to compile the "lrange" command. We only bother because we needed + * the opcode anyway for "lassign". + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLrangeCmd( + 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, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *tmpObj; + int idx1, idx2, result; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse the first index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx1); + if (result == TCL_OK) { + if (idx1 < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); + if (result == TCL_OK && idx1 > -2) { + result = TCL_ERROR; + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + + /* + * Parse the second index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing). + */ + + tokenPtr = TokenAfter(tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx2); + if (result == TCL_OK) { + if (idx2 < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); + if (result == TCL_OK && idx2 > -2) { + result = TCL_ERROR; + } + } + TclDecrRefCount(tmpObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + + /* + * Issue instructions. It's not safe to skip doing the LIST_RANGE, as + * we've not proved that the 'list' argument is really a list. Not that it + * is worth trying to do that given current knowledge. + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileLsetCmd -- * * Procedure called to compile the "lset" command. diff --git a/generic/tclInt.h b/generic/tclInt.h index feede54..37fce70 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3547,6 +3547,9 @@ MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |