Compilation of [string first] and [string range] (with constant indices).

1 files changed, 209 insertions, 70 deletions

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index b8dada5..12396fe 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -133,6 +133,8 @@ const AuxDataType tclJumptableInfoType = {
 #define OP(name)	TclEmitOpcode(INST_##name, envPtr)
 #define OP1(name,val)	TclEmitInstInt1(INST_##name,(val),envPtr)
 #define OP4(name,val)	TclEmitInstInt4(INST_##name,(val),envPtr)
+#define OP14(name,val1,val2) \
+    TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
 #define OP44(name,val1,val2) \
     TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
 #define BODY(token,index) \
@@ -351,6 +353,57 @@ TclCompileStringEqualCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringFirstCmd --
+ *
+ *	Procedure called to compile the simplest and most common form of the
+ *	"string first" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "string first"
+ *	command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringFirstCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr;
+
+    /*
+     * We don't support any flags; the bytecode isn't that sophisticated.
+     */
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Push the two operands onto the stack and then the test.
+     */
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr, interp, 1);
+    tokenPtr = TokenAfter(tokenPtr);
+    CompileWord(envPtr, tokenPtr, interp, 2);
+    OP(STR_FIND);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileStringIndexCmd --
  *
  *	Procedure called to compile the simplest and most common form of the
@@ -630,7 +683,7 @@ TclCompileStringMapCmd(
 	bytes = Tcl_GetStringFromObj(objv[1], &len);
 	PushLiteral(envPtr, bytes, len);
 	CompileWord(envPtr, stringTokenPtr, interp, 2);
-	TclEmitOpcode(INST_STR_MAP, envPtr);
+	OP(STR_MAP);
     }
     Tcl_DecrRefCount(mapObj);
     return TCL_OK;
@@ -639,6 +692,113 @@ TclCompileStringMapCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringRangeCmd --
+ *
+ *	Procedure called to compile the "string range" command (with constant
+ *	indices).
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "string compare"
+ *	command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringRangeCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *stringTokenPtr, *tokenPtr;
+    Tcl_Obj *tmpObj;
+    int idx1, idx2, result;
+
+    /*
+     * We don't support any flags; the bytecode isn't that sophisticated.
+     */
+
+    if (parsePtr->numWords != 4) {
+	return TCL_ERROR;
+    }
+    stringTokenPtr = 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(stringTokenPtr);
+    tmpObj = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+	Tcl_DecrRefCount(tmpObj);
+	return TCL_ERROR;
+    }
+    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);
+    tmpObj = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+	Tcl_DecrRefCount(tmpObj);
+	return TCL_ERROR;
+    }
+    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;
+    }
+
+    /*
+     * Push the two operands onto the stack and then the test.
+     */
+
+    CompileWord(envPtr, stringTokenPtr, interp, 1);
+    OP44(	STR_RANGE_IMM, idx1, idx2);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileSubstCmd --
  *
  *	Procedure called to compile the "subst" command.
@@ -779,11 +939,11 @@ TclSubstCompile(
 	}
 
 	while (count > 255) {
-	    TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+	    OP1(		CONCAT1, 255);
 	    count -= 254;
 	}
 	if (count > 1) {
-	    TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+	    OP1(		CONCAT1, count);
 	    count = 1;
 	}
 
@@ -804,7 +964,7 @@ TclSubstCompile(
 
 	envPtr->line = bline;
 	catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-	TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr);
+	OP4(	BEGIN_CATCH4, catchRange);
 	ExceptionRangeStarts(envPtr, catchRange);
 
 	switch (tokenPtr->type) {
@@ -825,20 +985,20 @@ TclSubstCompile(
 	ExceptionRangeEnds(envPtr, catchRange);
 
 	/* Substitution produced TCL_OK */
-	TclEmitOpcode(INST_END_CATCH, envPtr);
+	OP(	END_CATCH);
 	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
 
 	/* Exceptional return codes processed here */
 	ExceptionRangeTarget(envPtr, catchRange, catchOffset);
-	TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
-	TclEmitOpcode(INST_PUSH_RESULT, envPtr);
-	TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
-	TclEmitOpcode(INST_END_CATCH, envPtr);
-	TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr);
+	OP(	PUSH_RETURN_OPTIONS);
+	OP(	PUSH_RESULT);
+	OP(	PUSH_RETURN_CODE);
+	OP(	END_CATCH);
+	OP(	RETURN_CODE_BRANCH);
 
 	/* ERROR -> reraise it */
-	TclEmitOpcode(INST_RETURN_STK, envPtr);
-	TclEmitOpcode(INST_NOP, envPtr);
+	OP(	RETURN_STK);
+	OP(	NOP);
 
 	/* RETURN */
 	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);
@@ -857,14 +1017,14 @@ TclSubstCompile(
 	    Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
 		    (int) (CurrentOffset(envPtr) - breakFixup.codeOffset));
 	}
-	TclEmitOpcode(INST_POP, envPtr);
-	TclEmitOpcode(INST_POP, envPtr);
+	OP(	POP);
+	OP(	POP);
 
 	breakJump = CurrentOffset(envPtr) - breakOffset;
 	if (breakJump > 127) {
-	    TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr);
+	    OP4(JUMP4, -breakJump);
 	} else {
-	    TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr);
+	    OP1(JUMP1, -breakJump);
 	}
 
 	/* CONTINUE destination */
@@ -872,8 +1032,8 @@ TclSubstCompile(
 	    Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
 		    (int) (CurrentOffset(envPtr) - continueFixup.codeOffset));
 	}
-	TclEmitOpcode(INST_POP, envPtr);
-	TclEmitOpcode(INST_POP, envPtr);
+	OP(	POP);
+	OP(	POP);
 	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
 
 	/* RETURN + other destination */
@@ -890,8 +1050,8 @@ TclSubstCompile(
 	 * Pull the result to top of stack, discard options dict.
 	 */
 
-	TclEmitInstInt4(INST_REVERSE, 2, envPtr);
-	TclEmitOpcode(INST_POP, envPtr);
+	OP4(	REVERSE, 2);
+	OP(	POP);
 
 	/*
 	 * We've emitted several POP instructions, and the automatic
@@ -910,7 +1070,7 @@ TclSubstCompile(
 		    (int) (CurrentOffset(envPtr) - okFixup.codeOffset));
 	}
 	if (count > 1) {
-	    TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+	    OP1(CONCAT1, count);
 	    count = 1;
 	}
 
@@ -922,13 +1082,12 @@ TclSubstCompile(
 	bline = envPtr->line;
     }
 
-
     while (count > 255) {
-	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+	OP1(	CONCAT1, 255);
 	count -= 254;
     }
     if (count > 1) {
-	TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+	OP1(	CONCAT1, count);
     }
 
     Tcl_FreeParse(&parse);
@@ -1359,14 +1518,14 @@ IssueSwitchChainedTests(
 
 	    switch (mode) {
 	    case Switch_Exact:
-		TclEmitOpcode(INST_DUP,				envPtr);
+		OP(	DUP);
 		TclCompileTokens(interp, bodyToken[i], 1,	envPtr);
-		TclEmitOpcode(INST_STR_EQ,			envPtr);
+		OP(	STR_EQ);
 		break;
 	    case Switch_Glob:
 		TclCompileTokens(interp, bodyToken[i], 1,	envPtr);
-		TclEmitInstInt4(INST_OVER, 1,			envPtr);
-		TclEmitInstInt1(INST_STR_MATCH, noCase,		envPtr);
+		OP4(	OVER, 1);
+		OP1(	STR_MATCH, noCase);
 		break;
 	    case Switch_Regexp:
 		simple = exact = 0;
@@ -1405,7 +1564,7 @@ IssueSwitchChainedTests(
 		    TclCompileTokens(interp, bodyToken[i], 1, envPtr);
 		}
 
-		TclEmitInstInt4(INST_OVER, 1,			envPtr);
+		OP4(	OVER, 1);
 		if (!simple) {
 		    /*
 		     * Pass correct RE compile flags. We use only Int1
@@ -1417,11 +1576,11 @@ IssueSwitchChainedTests(
 		    int cflags = TCL_REG_ADVANCED
 			    | (noCase ? TCL_REG_NOCASE : 0);
 
-		    TclEmitInstInt1(INST_REGEXP, cflags,	envPtr);
+		    OP1(REGEXP, cflags);
 		} else if (exact && !noCase) {
-		    TclEmitOpcode(INST_STR_EQ,			envPtr);
+		    OP(	STR_EQ);
 		} else {
-		    TclEmitInstInt1(INST_STR_MATCH, noCase,	envPtr);
+		    OP1(STR_MATCH, noCase);
 		}
 		break;
 	    default:
@@ -1486,7 +1645,7 @@ IssueSwitchChainedTests(
 	 * pattern.
 	 */
 
-	TclEmitOpcode(INST_POP,					envPtr);
+	OP(	POP);
 	envPtr->currStackDepth = savedStackDepth + 1;
 	envPtr->line = bodyLines[i+1];		/* TIP #280 */
 	envPtr->clNext = bodyContLines[i+1];	/* TIP #280 */
@@ -1508,7 +1667,7 @@ IssueSwitchChainedTests(
      */
 
     if (!foundDefault) {
-	TclEmitOpcode(INST_POP,					envPtr);
+	OP(	POP);
 	PushLiteral(envPtr, "", 0);
     }
 
@@ -1619,9 +1778,9 @@ IssueSwitchJumpTable(
      */
 
     jumpLocation = CurrentOffset(envPtr);
-    TclEmitInstInt4(INST_JUMP_TABLE, infoIndex,			envPtr);
+    OP4(	JUMP_TABLE, infoIndex);
     jumpToDefault = CurrentOffset(envPtr);
-    TclEmitInstInt4(INST_JUMP4, 0,				envPtr);
+    OP4(	JUMP4, 0);
 
     for (i=0 ; i<numBodyTokens ; i+=2) {
 	/*
@@ -1712,7 +1871,7 @@ IssueSwitchJumpTable(
 	     * rewriting when we fixed this all up.
 	     */
 
-	    TclEmitInstInt4(INST_JUMP4, 0,			envPtr);
+	    OP4(	JUMP4, 0);
 	}
     }
 
@@ -2629,20 +2788,18 @@ TclCompileUnsetCmd(
 	 */
 
 	if (!simpleVarName) {
-	    TclEmitInstInt1(	INST_UNSET_STK, flags,		envPtr);
+	    OP1(	UNSET_STK, flags);
 	} else if (isScalar) {
 	    if (localIndex < 0) {
-		TclEmitInstInt1(INST_UNSET_STK, flags,		envPtr);
+		OP1(	UNSET_STK, flags);
 	    } else {
-		TclEmitInstInt1(INST_UNSET_SCALAR, flags,	envPtr);
-		TclEmitInt4(			   localIndex,	envPtr);
+		OP14(	UNSET_SCALAR, flags, localIndex);
 	    }
 	} else {
 	    if (localIndex < 0) {
-		TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags,	envPtr);
+		OP1(	UNSET_ARRAY_STK, flags);
 	    } else {
-		TclEmitInstInt1(INST_UNSET_ARRAY, flags,	envPtr);
-		TclEmitInt4(			  localIndex,	envPtr);
+		OP14(	UNSET_ARRAY, flags, localIndex);
 	    }
 	}
 
@@ -2779,7 +2936,7 @@ TclCompileWhileCmd(
     CompileBody(envPtr, bodyTokenPtr, interp);
     ExceptionRangeEnds(envPtr, range);
     envPtr->currStackDepth = savedStackDepth + 1;
-    TclEmitOpcode(INST_POP, envPtr);
+    OP(		POP);
 
     /*
      * Compile the test expression then emit the conditional jump that
@@ -2870,7 +3027,7 @@ TclCompileYieldCmd(
 
 	CompileWord(envPtr, valueTokenPtr, interp, 1);
     }
-    TclEmitOpcode(INST_YIELD, envPtr);
+    OP(		YIELD);
     return TCL_OK;
 }
 
@@ -3199,7 +3356,7 @@ CompileAssociativeBinaryOpCmd(
 	 * calcuations, including roundoff errors.
 	 */
 
-	TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+	OP4(	REVERSE, words-1);
     }
     while (--words > 1) {
 	TclEmitOpcode(instruction, envPtr);
@@ -3290,31 +3447,19 @@ CompileComparisonOpCmd(
 	CompileWord(envPtr, tokenPtr, interp, 1);
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr, interp, 2);
-	if (tmpIndex <= 255) {
-	    TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
-	} else {
-	    TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
-	}
+	STORE(tmpIndex);
 	TclEmitOpcode(instruction, envPtr);
 	for (words=3 ; words<parsePtr->numWords ;) {
-	    if (tmpIndex <= 255) {
-		TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
-	    }
+	    LOAD(tmpIndex);
 	    tokenPtr = TokenAfter(tokenPtr);
 	    CompileWord(envPtr, tokenPtr, interp, words);
 	    if (++words < parsePtr->numWords) {
-		if (tmpIndex <= 255) {
-		    TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
-		} else {
-		    TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
-		}
+		STORE(tmpIndex);
 	    }
 	    TclEmitOpcode(instruction, envPtr);
 	}
 	for (; words>3 ; words--) {
-	    TclEmitOpcode(INST_BITAND, envPtr);
+	    OP(	BITAND);
 	}
 
 	/*
@@ -3322,13 +3467,7 @@ CompileComparisonOpCmd(
 	 * might be expensive elsewhere.
 	 */
 
-	PushLiteral(envPtr, "", 0);
-	if (tmpIndex <= 255) {
-	    TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
-	} else {
-	    TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
-	}
-	TclEmitOpcode(INST_POP, envPtr);
+	OP14(	UNSET_SCALAR, 0, tmpIndex);
     }
     return TCL_OK;
 }