diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclBasic.c | 2 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 124 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 |
4 files changed, 133 insertions, 4 deletions
@@ -1,8 +1,10 @@ 2012-02-15 Donal K. Fellows <dkf@users.sf.net> - * generic/tclCompCmds.c (TclCompileLrangeCmd): Add compiler for - [lrange] with constant indices so we can take advantage of existing - TCL_LIST_RANGE_IMM opcode. + * generic/tclCompCmds.c (TclCompileLreplaceCmd): Added a compilation + strategy for [lreplace] that tackles the cases which are equivalent to + a static [lrange]. + (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. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d67153c..c07fa70 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -232,7 +232,7 @@ static const CmdInfo builtInCmds[] = { {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, NULL, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c96f05c..5b7e0a5 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3405,6 +3405,130 @@ TclCompileLrangeCmd( /* *---------------------------------------------------------------------- * + * TclCompileLreplaceCmd -- + * + * How to compile the "lreplace" command. We only bother with the case + * where there are no elements to insert and where both the 'first' and + * 'last' arguments are constant and one can be deterined to be at the + * end of the list. (This is the case that could also be written with + * "lrange".) + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLreplaceCmd( + 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, guaranteedDropAll = 0; + + 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; + } + + /* + * Sanity check: can only issue when we're removing a range at one or + * other end of the list. If we're at one end or the other, convert the + * indices into the equivalent for an [lrange]. + */ + + if (idx1 == 0) { + if (idx2 == -2) { + guaranteedDropAll = 1; + } + idx1 = idx2 + 1; + idx2 = -2; + } else if (idx2 == -2) { + idx2 = idx1 - 1; + idx1 = 0; + } else { + 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); + if (guaranteedDropAll) { + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + } else { + 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 37fce70..08b3f70 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3550,6 +3550,9 @@ MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLreplaceCmd(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); |