summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-02-15 20:43:08 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-02-15 20:43:08 (GMT)
commit182448a5403990b1f583b5f9cf6cf6d8e2b7c8de (patch)
tree0c8ee86e4a1dfdbe9ad52a7e66349e03ea8ad569
parentef8842098dc6103ef6fc6fc7deb1b7e5395e85a2 (diff)
downloadtcl-182448a5403990b1f583b5f9cf6cf6d8e2b7c8de.zip
tcl-182448a5403990b1f583b5f9cf6cf6d8e2b7c8de.tar.gz
tcl-182448a5403990b1f583b5f9cf6cf6d8e2b7c8de.tar.bz2
* generic/tclCompCmds.c (TclCompileLreplaceCmd): Added a compilation
strategy for [lreplace] that tackles the cases which are equivalent to a static [lrange].
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclBasic.c2
-rw-r--r--generic/tclCompCmds.c124
-rw-r--r--generic/tclInt.h3
4 files changed, 133 insertions, 4 deletions
diff --git a/ChangeLog b/ChangeLog
index d29f6aa..e5d23bf 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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);