Added compilation of simplest practical case of [string map].

7 files changed, 160 insertions, 13 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 5ff96fd..10df71a 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -474,6 +474,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"streq",		ASSEM_1BYTE,	INST_STR_EQ,		2,	1},
     {"strindex",	ASSEM_1BYTE,	INST_STR_INDEX,		2,	1},
     {"strlen",		ASSEM_1BYTE,	INST_STR_LEN,		1,	1},
+    {"strmap",		ASSEM_1BYTE,	INST_STR_MAP,		3,	1},
     {"strmatch",	ASSEM_BOOL,	INST_STR_MATCH,		2,	1},
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
@@ -507,10 +508,11 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_PUSH_RETURN_OPTIONS,					/* 108 */
     INST_REVERSE,						/* 126 */
     INST_NOP,							/* 132 */
-    INST_COROUTINE_NAME,					/* 142 */
-    INST_NS_CURRENT,						/* 143 */
-    INST_INFO_LEVEL_NUM,					/* 144 */
-    INST_RESOLVE_COMMAND					/* 146 */
+    INST_STR_MAP,						/* 141 */
+    INST_COROUTINE_NAME,					/* 143 */
+    INST_NS_CURRENT,						/* 144 */
+    INST_INFO_LEVEL_NUM,					/* 145 */
+    INST_RESOLVE_COMMAND					/* 147 */
 };
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 9e720ea..1f210dd 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3309,7 +3309,7 @@ TclInitStringCmd(
 	{"is",		StringIsCmd,	NULL, NULL, NULL, 0},
 	{"last",	StringLastCmd,	NULL, NULL, NULL, 0},
 	{"length",	StringLenCmd,	TclCompileStringLenCmd, NULL, NULL, 0},
-	{"map",		StringMapCmd,	NULL, NULL, NULL, 0},
+	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
 	{"match",	StringMatchCmd,	TclCompileStringMatchCmd, NULL, NULL, 0},
 	{"range",	StringRangeCmd,	NULL, NULL, NULL, 0},
 	{"repeat",	StringReptCmd,	NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index d7dd58e..b8dada5 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -557,6 +557,88 @@ TclCompileStringLenCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringMapCmd --
+ *
+ *	Procedure called to compile the simplest and most common form of the
+ *	"string map" 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 map" command
+ *	at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringMapCmd(
+    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 *mapTokenPtr, *stringTokenPtr;
+    Tcl_Obj *mapObj, **objv;
+    char *bytes;
+    int len;
+
+    /*
+     * We only handle the case:
+     *
+     *    string map {foo bar} $thing
+     *
+     * That is, a literal two-element list (doesn't need to be brace-quoted,
+     * but does need to be compile-time knowable) and any old argument (the
+     * thing to map).
+     */
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+    mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    stringTokenPtr = TokenAfter(mapTokenPtr);
+    mapObj = Tcl_NewObj();
+    Tcl_IncrRefCount(mapObj);
+    if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
+	Tcl_DecrRefCount(mapObj);
+	return TCL_ERROR;
+    } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
+	Tcl_DecrRefCount(mapObj);
+	return TCL_ERROR;
+    } else if (len != 2) {
+	Tcl_DecrRefCount(mapObj);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Now issue the opcodes. Note that in the case that we know that the
+     * first word is an empty word, we don't issue the map at all. That is the
+     * correct semantics for mapping.
+     */
+
+    bytes = Tcl_GetStringFromObj(objv[0], &len);
+    if (len == 0) {
+	CompileWord(envPtr, stringTokenPtr, interp, 2);
+    } else {
+	PushLiteral(envPtr, bytes, len);
+	bytes = Tcl_GetStringFromObj(objv[1], &len);
+	PushLiteral(envPtr, bytes, len);
+	CompileWord(envPtr, stringTokenPtr, interp, 2);
+	TclEmitOpcode(INST_STR_MAP, envPtr);
+    }
+    Tcl_DecrRefCount(mapObj);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileSubstCmd --
  *
  *	Procedure called to compile the "subst" command.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 1924334..8b98746 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -435,6 +435,11 @@ InstructionDesc const tclInstructionTable[] = {
          * indicated by the LVT index. Part of [dict with].
 	 * Stack:  ... path keyList => ... */
 
+    {"strmap",		 1,    -2,	  0,	{OPERAND_NONE}},
+	/* Simplified version of [string map] that only applies one change
+	 * string, and only case-sensitively.
+	 * Stack:  ... from to string => changedString */
+
     {"yield",		 1,	0,	  0,	{OPERAND_NONE}},
 	/* Makes the current coroutine yield the value at the top of the
 	 * stack, and places the response back on top of the stack when it
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index fcff46c..ff2f0e3 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -681,19 +681,22 @@ typedef struct ByteCode {
 #define INST_DICT_RECOMBINE_STK		139
 #define INST_DICT_RECOMBINE_IMM		140
 
+/* For [string map] and [regsub] compilation */
+#define INST_STR_MAP			141
+
 /* For operations to do with coroutines */
-#define INST_YIELD			141
-#define INST_COROUTINE_NAME		142
+#define INST_YIELD			142
+#define INST_COROUTINE_NAME		143
 
 /* For compilation of basic information operations */
-#define INST_NS_CURRENT			143
-#define INST_INFO_LEVEL_NUM		144
-#define INST_INFO_LEVEL_ARGS		145
-#define INST_RESOLVE_COMMAND		146
-#define INST_TCLOO_SELF			147
+#define INST_NS_CURRENT			144
+#define INST_INFO_LEVEL_NUM		145
+#define INST_INFO_LEVEL_ARGS		146
+#define INST_RESOLVE_COMMAND		147
+#define INST_TCLOO_SELF			148
 
 /* The last opcode */
-#define LAST_INST_OPCODE		147
+#define LAST_INST_OPCODE		148
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b42e4ab..10cbf46 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4732,6 +4732,58 @@ TEBCresume(
 		O2S(objResultPtr)));
 	NEXT_INST_F(1, 2, 1);
 
+    case INST_STR_MAP: {
+	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
+	int length3;
+	Tcl_Obj *value3Ptr;
+
+	valuePtr = OBJ_AT_TOS;		/* "Main" string. */
+	value3Ptr = OBJ_UNDER_TOS;	/* "Target" string. */
+	value2Ptr = OBJ_AT_DEPTH(2);	/* "Source" string. */
+	if (value3Ptr == value2Ptr || valuePtr == value2Ptr) {
+	    objResultPtr = valuePtr;
+	    NEXT_INST_V(1, 3, 1);
+	}
+	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+	if (length == 0) {
+	    objResultPtr = valuePtr;
+	    NEXT_INST_V(1, 3, 1);
+	}
+	ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+	if (length2 > length || length2 == 0) {
+	    objResultPtr = valuePtr;
+	    NEXT_INST_V(1, 3, 1);
+	}
+	ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
+
+	objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+	p = ustring1;
+	end = ustring1 + length;
+	for (; ustring1 < end; ustring1++) {
+	    if ((*ustring1 == *ustring2) &&
+		    (length2==1 || Tcl_UniCharNcmp(ustring1, ustring2,
+				(unsigned long) length2) == 0)) {
+		if (p != ustring1) {
+		    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
+		    p = ustring1 + length2;
+		} else {
+		    p += length2;
+		}
+		ustring1 = p - 1;
+
+		Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3);
+	    }
+	}
+	if (p != ustring1) {
+	    /*
+	     * Put the rest of the unmapped chars onto result.
+	     */
+
+	    Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
+	}
+	NEXT_INST_V(1, 3, 1);
+    }
+
     case INST_STR_MATCH:
 	nocase = TclGetInt1AtPtr(pc+1);
 	valuePtr = OBJ_AT_TOS;		/* String */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 46c7a13..3aaed4c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3634,6 +3634,9 @@ MODULE_SCOPE int	TclCompileStringIndexCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileStringLenCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileStringMapCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileStringMatchCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);