summaryrefslogtreecommitdiffstats
path: root/generic/tclCompCmds.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-02-15 12:02:48 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-02-15 12:02:48 (GMT)
commitef8842098dc6103ef6fc6fc7deb1b7e5395e85a2 (patch)
tree9e92fe62aa3daa6cfefd6a65813ad18546ab28aa /generic/tclCompCmds.c
parent3aa1601f2afddd655694ff5cd8541c0572736c3c (diff)
downloadtcl-ef8842098dc6103ef6fc6fc7deb1b7e5395e85a2.zip
tcl-ef8842098dc6103ef6fc6fc7deb1b7e5395e85a2.tar.gz
tcl-ef8842098dc6103ef6fc6fc7deb1b7e5395e85a2.tar.bz2
* 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.
Diffstat (limited to 'generic/tclCompCmds.c')
-rw-r--r--generic/tclCompCmds.c113
1 files changed, 110 insertions, 3 deletions
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.