summaryrefslogtreecommitdiffstats
path: root/generic/tclCompCmds.c
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 /generic/tclCompCmds.c
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].
Diffstat (limited to 'generic/tclCompCmds.c')
-rw-r--r--generic/tclCompCmds.c124
1 files changed, 124 insertions, 0 deletions
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.