summaryrefslogtreecommitdiffstats
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
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.
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclBasic.c2
-rw-r--r--generic/tclCompCmds.c113
-rw-r--r--generic/tclInt.h3
4 files changed, 123 insertions, 7 deletions
diff --git a/ChangeLog b/ChangeLog
index e28342b..d29f6aa 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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);