summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c2
-rw-r--r--generic/tclCompCmdsGR.c278
-rw-r--r--generic/tclInt.h3
3 files changed, 160 insertions, 123 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a41351e..9f40932 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -227,7 +227,7 @@ static const CmdInfo builtInCmds[] = {
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE},
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE},
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
- {"linsert", Tcl_LinsertObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index e695068..c5a0126 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -27,7 +27,57 @@ static void CompileReturnInternal(CompileEnv *envPtr,
Tcl_Obj *returnOpts);
static int IndexTailVarIfKnown(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLinsertCmd --
+ *
+ * Parse a token and get the encoded version of the index (as understood
+ * by TEBC), assuming it is at all knowable at compile time. Only handles
+ * indices that are integers or 'end' or 'end-integer'.
+ *
+ * Returns:
+ * TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
+ *
+ * Side effects:
+ * Sets *index to the index value if successful.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+GetIndexFromToken(
+ Tcl_Token *tokenPtr,
+ int *index)
+{
+ Tcl_Obj *tmpObj = Tcl_NewObj();
+ int result, idx;
+
+ if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+ Tcl_DecrRefCount(tmpObj);
+ return TCL_ERROR;
+ }
+ 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;
+ }
+ }
+ Tcl_DecrRefCount(tmpObj);
+
+ if (result == TCL_OK) {
+ *index = idx;
+ }
+
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -1060,7 +1110,7 @@ TclCompileLindexCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *idxTokenPtr, *valTokenPtr;
- int i, numWords = parsePtr->numWords;
+ int i, idx, numWords = parsePtr->numWords;
DefineLineInformation; /* TIP #280 */
/*
@@ -1078,46 +1128,28 @@ TclCompileLindexCmd(
}
idxTokenPtr = TokenAfter(valTokenPtr);
- if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- Tcl_Obj *tmpObj;
- int idx, result;
-
- 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) {
- /*
- * 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.
- */
-
- CompileWord(envPtr, valTokenPtr, interp, 1);
- TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
- return TCL_OK;
- }
-
+ if (GetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) {
/*
- * If the conversion failed or the value was negative, we just keep on
- * going with the more complex compilation.
+ * 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.
*/
+
+ CompileWord(envPtr, valTokenPtr, interp, 1);
+ TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
+ return TCL_OK;
}
/*
+ * If the value was not known at compile time, the conversion failed or
+ * the value was negative, we just keep on going with the more complex
+ * compilation.
+ */
+
+ /*
* Push the operands onto the stack.
*/
@@ -1330,8 +1362,7 @@ TclCompileLrangeCmd(
{
Tcl_Token *tokenPtr, *listTokenPtr;
DefineLineInformation; /* TIP #280 */
- Tcl_Obj *tmpObj;
- int idx1, idx2, result;
+ int idx1, idx2;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
@@ -1339,56 +1370,18 @@ TclCompileLrangeCmd(
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
- * Parse the first index. Will only compile if it is constant and not an
+ * Parse the indices. Will only compile if both are constants and not an
* _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
+ * end-relative indexing) or an end-based index greater than 'end' itself.
*/
tokenPtr = TokenAfter(listTokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
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) {
+ if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
return TCL_ERROR;
}
@@ -1407,19 +1400,16 @@ TclCompileLrangeCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileLreplaceCmd --
+ * TclCompileLinsertCmd --
*
- * 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".)
+ * How to compile the "linsert" command. We only bother with the case
+ * where the index is constant.
*
*----------------------------------------------------------------------
*/
int
-TclCompileLreplaceCmd(
+TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
@@ -1429,65 +1419,109 @@ TclCompileLreplaceCmd(
{
Tcl_Token *tokenPtr, *listTokenPtr;
DefineLineInformation; /* TIP #280 */
- Tcl_Obj *tmpObj;
- int idx1, idx2, result, i, offset;
+ int idx, i;
- if (parsePtr->numWords < 4) {
+ if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
- * Parse the first index. Will only compile if it is constant and not an
+ * Parse the 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).
+ * end-relative indexing) or an end-based index greater than 'end' itself.
*/
tokenPtr = TokenAfter(listTokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ if (GetIndexFromToken(tokenPtr, &idx) != TCL_OK) {
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;
- }
+
+ /*
+ * There are four main cases. If there are no values to insert, this is
+ * just a confirm-listiness check. If the index is '0', this is a prepend.
+ * If the index is 'end' (== -2), this is an append. Otherwise, this is a
+ * splice (== split, insert values as list, concat-3).
+ */
+
+ CompileWord(envPtr, listTokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( -2, envPtr);
+ return TCL_OK;
+ }
+
+ for (i=3 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
+ }
+ TclEmitInstInt4( INST_LIST, i-3, envPtr);
+
+ if (idx == 0 /*start*/) {
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ } else if (idx == -2 /*end*/) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
} else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
- if (result == TCL_OK && idx1 > -2) {
- result = TCL_ERROR;
+ if (idx < 0) {
+ idx++;
}
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( idx-1, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 3, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
+ TclEmitInt4( -2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
}
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLreplaceCmd --
+ *
+ * How to compile the "lreplace" command. We only bother with the case
+ * where the indices are constant.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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, i, offset;
+
+ if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
+ listTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
- * Parse the second index. Will only compile if it is constant and not an
+ * Parse the indices. Will only compile if both are constants and not an
* _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
+ * end-relative indexing) or an end-based index greater than 'end' itself.
*/
- tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ tokenPtr = TokenAfter(listTokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
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) {
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
return TCL_ERROR;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2312734..6fe07f8 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3533,6 +3533,9 @@ MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
generated by cgit v0.12 at 2024-11-25 23:25:47 (GMT)