Merge tip of core-8-6-branchbug_16828b3744

1 files changed, 888 insertions, 87 deletions

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index d1eb9db..101edbd 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -17,6 +17,7 @@
 
 #include "tclInt.h"
 #include "tclCompile.h"
+#include "tclStringTrim.h"
 
 /*
  * Prototypes for procedures defined later in this file:
@@ -27,6 +28,9 @@ static void		FreeJumptableInfo(ClientData clientData);
 static void		PrintJumptableInfo(ClientData clientData,
 			    Tcl_Obj *appendObj, ByteCode *codePtr,
 			    unsigned int pcOffset);
+static void		DisassembleJumptableInfo(ClientData clientData,
+			    Tcl_Obj *dictObj, ByteCode *codePtr,
+			    unsigned int pcOffset);
 static int		CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, const char *identity,
 			    int instruction, CompileEnv *envPtr);
@@ -71,7 +75,8 @@ const AuxDataType tclJumptableInfoType = {
     "JumptableInfo",		/* name */
     DupJumptableInfo,		/* dupProc */
     FreeJumptableInfo,		/* freeProc */
-    PrintJumptableInfo		/* printProc */
+    PrintJumptableInfo,		/* printProc */
+    DisassembleJumptableInfo	/* disassembleProc */
 };
 
 /*
@@ -99,6 +104,61 @@ const AuxDataType tclJumptableInfoType = {
     if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
 #define STORE(idx) \
     if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
+#define INVOKE(name) \
+    TclEmitInvoke(envPtr,INST_##name)
+
+#define INDEX_END	(-2)
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetIndexFromToken --
+ *
+ *	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, INDEX_END, &idx);
+	if (result == TCL_OK && idx > INDEX_END) {
+	    result = TCL_ERROR;
+	}
+    }
+    Tcl_DecrRefCount(tmpObj);
+
+    if (result == TCL_OK) {
+	*index = idx;
+    }
+
+    return result;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -213,6 +273,78 @@ TclCompileSetCmd(
  */
 
 int
+TclCompileStringCatCmd(
+    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. */
+{
+    int i, numWords = parsePtr->numWords, numArgs;
+    Tcl_Token *wordTokenPtr;
+    Tcl_Obj *obj, *folded;
+    DefineLineInformation;	/* TIP #280 */
+
+    /* Trivial case, no arg */
+
+    if (numWords<2) {
+	PushStringLiteral(envPtr, "");
+	return TCL_OK;
+    }
+
+    /* General case: issue CONCAT1's (by chunks of 254 if needed), folding
+       contiguous constants along the way */
+
+    numArgs = 0;
+    folded = NULL;
+    wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    for (i = 1; i < numWords; i++) {
+	obj = Tcl_NewObj();
+	if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) {
+	    if (folded) {
+		Tcl_AppendObjToObj(folded, obj);
+		Tcl_DecrRefCount(obj);
+	    } else {
+		folded = obj;
+	    }
+	} else {
+	    Tcl_DecrRefCount(obj);
+	    if (folded) {
+		int len;
+		const char *bytes = Tcl_GetStringFromObj(folded, &len);
+
+		PushLiteral(envPtr, bytes, len);
+		Tcl_DecrRefCount(folded);
+		folded = NULL;
+		numArgs ++;
+	    }
+	    CompileWord(envPtr, wordTokenPtr, interp, i);
+	    numArgs ++;
+	    if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */
+		TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
+		numArgs = 1;	/* concat pushes 1 obj, the result */
+	    }
+	}
+	wordTokenPtr = TokenAfter(wordTokenPtr);
+    }
+    if (folded) {
+	int len;
+	const char *bytes = Tcl_GetStringFromObj(folded, &len);
+
+	PushLiteral(envPtr, bytes, len);
+	Tcl_DecrRefCount(folded);
+	folded = NULL;
+	numArgs ++;
+    }
+    if (numArgs > 1) {
+	TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
+    }
+
+    return TCL_OK;
+}
+
+int
 TclCompileStringCmpCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
@@ -369,6 +501,284 @@ TclCompileStringIndexCmd(
 }
 
 int
+TclCompileStringIsCmd(
+    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 = TokenAfter(parsePtr->tokenPtr);
+    static const char *const isClasses[] = {
+	"alnum",	"alpha",	"ascii",	"control",
+	"boolean",	"digit",	"double",	"entier",
+	"false",	"graph",	"integer",	"list",
+	"lower",	"print",	"punct",	"space",
+	"true",		"upper",	"wideinteger",	"wordchar",
+	"xdigit",	NULL
+    };
+    enum isClasses {
+	STR_IS_ALNUM,	STR_IS_ALPHA,	STR_IS_ASCII,	STR_IS_CONTROL,
+	STR_IS_BOOL,	STR_IS_DIGIT,	STR_IS_DOUBLE,	STR_IS_ENTIER,
+	STR_IS_FALSE,	STR_IS_GRAPH,	STR_IS_INT,	STR_IS_LIST,
+	STR_IS_LOWER,	STR_IS_PRINT,	STR_IS_PUNCT,	STR_IS_SPACE,
+	STR_IS_TRUE,	STR_IS_UPPER,	STR_IS_WIDE,	STR_IS_WORD,
+	STR_IS_XDIGIT
+    };
+    int t, range, allowEmpty = 0, end;
+    InstStringClassType strClassType;
+    Tcl_Obj *isClass;
+
+    if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
+	return TCL_ERROR;
+    }
+    isClass = Tcl_NewObj();
+    if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) {
+	Tcl_DecrRefCount(isClass);
+	return TCL_ERROR;
+    } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0,
+	    &t) != TCL_OK) {
+	Tcl_DecrRefCount(isClass);
+	TclCompileSyntaxError(interp, envPtr);
+	return TCL_OK;
+    }
+    Tcl_DecrRefCount(isClass);
+
+#define GotLiteral(tokenPtr, word) \
+    ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD &&			\
+     (tokenPtr)[1].size > 1 &&						\
+     (tokenPtr)[1].start[0] == word[0] &&				\
+     strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
+
+    /*
+     * Cannot handle the -failindex option at all, and that's the only legal
+     * way to have more than 4 arguments.
+     */
+
+    if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
+	return TCL_ERROR;
+    }
+
+    tokenPtr = TokenAfter(tokenPtr);
+    if (parsePtr->numWords == 3) {
+	allowEmpty = 1;
+    } else {
+	if (!GotLiteral(tokenPtr, "-strict")) {
+	    return TCL_ERROR;
+	}
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+#undef GotLiteral
+
+    /*
+     * Compile the code. There are several main classes of check here.
+     *	1. Character classes
+     *	2. Booleans
+     *	3. Integers
+     *	4. Floats
+     *	5. Lists
+     */
+
+    CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+
+    switch ((enum isClasses) t) {
+    case STR_IS_ALNUM:
+	strClassType = STR_CLASS_ALNUM;
+	goto compileStrClass;
+    case STR_IS_ALPHA:
+	strClassType = STR_CLASS_ALPHA;
+	goto compileStrClass;
+    case STR_IS_ASCII:
+	strClassType = STR_CLASS_ASCII;
+	goto compileStrClass;
+    case STR_IS_CONTROL:
+	strClassType = STR_CLASS_CONTROL;
+	goto compileStrClass;
+    case STR_IS_DIGIT:
+	strClassType = STR_CLASS_DIGIT;
+	goto compileStrClass;
+    case STR_IS_GRAPH:
+	strClassType = STR_CLASS_GRAPH;
+	goto compileStrClass;
+    case STR_IS_LOWER:
+	strClassType = STR_CLASS_LOWER;
+	goto compileStrClass;
+    case STR_IS_PRINT:
+	strClassType = STR_CLASS_PRINT;
+	goto compileStrClass;
+    case STR_IS_PUNCT:
+	strClassType = STR_CLASS_PUNCT;
+	goto compileStrClass;
+    case STR_IS_SPACE:
+	strClassType = STR_CLASS_SPACE;
+	goto compileStrClass;
+    case STR_IS_UPPER:
+	strClassType = STR_CLASS_UPPER;
+	goto compileStrClass;
+    case STR_IS_WORD:
+	strClassType = STR_CLASS_WORD;
+	goto compileStrClass;
+    case STR_IS_XDIGIT:
+	strClassType = STR_CLASS_XDIGIT;
+    compileStrClass:
+	if (allowEmpty) {
+	    OP1(	STR_CLASS, strClassType);
+	} else {
+	    int over, over2;
+
+	    OP(		DUP);
+	    OP1(	STR_CLASS, strClassType);
+	    JUMP1(	JUMP_TRUE, over);
+	    OP(		POP);
+	    PUSH(	"0");
+	    JUMP1(	JUMP, over2);
+	    FIXJUMP1(over);
+	    PUSH(	"");
+	    OP(		STR_NEQ);
+	    FIXJUMP1(over2);
+	}
+	return TCL_OK;
+
+    case STR_IS_BOOL:
+    case STR_IS_FALSE:
+    case STR_IS_TRUE:
+	OP(		TRY_CVT_TO_BOOLEAN);
+	switch (t) {
+	    int over, over2;
+
+	case STR_IS_BOOL:
+	    if (allowEmpty) {
+		JUMP1(	JUMP_TRUE, over);
+		PUSH(	"");
+		OP(	STR_EQ);
+		JUMP1(	JUMP, over2);
+		FIXJUMP1(over);
+		OP(	POP);
+		PUSH(	"1");
+		FIXJUMP1(over2);
+	    } else {
+		OP4(	REVERSE, 2);
+		OP(	POP);
+	    }
+	    return TCL_OK;
+	case STR_IS_TRUE:
+	    JUMP1(	JUMP_TRUE, over);
+	    if (allowEmpty) {
+		PUSH(	"");
+		OP(	STR_EQ);
+	    } else {
+		OP(	POP);
+		PUSH(	"0");
+	    }
+	    FIXJUMP1(	over);
+	    OP(		LNOT);
+	    OP(		LNOT);
+	    return TCL_OK;
+	case STR_IS_FALSE:
+	    JUMP1(	JUMP_TRUE, over);
+	    if (allowEmpty) {
+		PUSH(	"");
+		OP(	STR_NEQ);
+	    } else {
+		OP(	POP);
+		PUSH(	"1");
+	    }
+	    FIXJUMP1(	over);
+	    OP(		LNOT);
+	    return TCL_OK;
+	}
+
+    case STR_IS_DOUBLE: {
+	int satisfied, isEmpty;
+
+	if (allowEmpty) {
+	    OP(		DUP);
+	    PUSH(	"");
+	    OP(		STR_EQ);
+	    JUMP1(	JUMP_TRUE, isEmpty);
+	    OP(		NUM_TYPE);
+	    JUMP1(	JUMP_TRUE, satisfied);
+	    PUSH(	"0");
+	    JUMP1(	JUMP, end);
+	    FIXJUMP1(	isEmpty);
+	    OP(		POP);
+	    FIXJUMP1(	satisfied);
+	} else {
+	    OP(		NUM_TYPE);
+	    JUMP1(	JUMP_TRUE, satisfied);
+	    PUSH(	"0");
+	    JUMP1(	JUMP, end);
+	    TclAdjustStackDepth(-1, envPtr);
+	    FIXJUMP1(	satisfied);
+	}
+	PUSH(		"1");
+	FIXJUMP1(	end);
+	return TCL_OK;
+    }
+
+    case STR_IS_INT:
+    case STR_IS_WIDE:
+    case STR_IS_ENTIER:
+	if (allowEmpty) {
+	    int testNumType;
+
+	    OP(		DUP);
+	    OP(		NUM_TYPE);
+	    OP(		DUP);
+	    JUMP1(	JUMP_TRUE, testNumType);
+	    OP(		POP);
+	    PUSH(	"");
+	    OP(		STR_EQ);
+	    JUMP1(	JUMP, end);
+	    TclAdjustStackDepth(1, envPtr);
+	    FIXJUMP1(	testNumType);
+	    OP4(	REVERSE, 2);
+	    OP(		POP);
+	} else {
+	    OP(		NUM_TYPE);
+	    OP(		DUP);
+	    JUMP1(	JUMP_FALSE, end);
+	}
+
+	switch (t) {
+	case STR_IS_INT:
+	    PUSH(	"1");
+	    OP(		EQ);
+	    break;
+	case STR_IS_WIDE:
+	    PUSH(	"2");
+	    OP(		LE);
+	    break;
+	case STR_IS_ENTIER:
+	    PUSH(	"3");
+	    OP(		LE);
+	    break;
+	}
+	FIXJUMP1(	end);
+	return TCL_OK;
+
+    case STR_IS_LIST:
+	range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+	OP4(		BEGIN_CATCH4, range);
+	ExceptionRangeStarts(envPtr, range);
+	OP(		DUP);
+	OP(		LIST_LENGTH);
+	OP(		POP);
+	ExceptionRangeEnds(envPtr, range);
+	ExceptionRangeTarget(envPtr, range, catchOffset);
+	OP(		POP);
+	OP(		PUSH_RETURN_CODE);
+	OP(		END_CATCH);
+	OP(		LNOT);
+	return TCL_OK;
+    }
+
+    return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
 TclCompileStringMatchCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
@@ -563,8 +973,7 @@ TclCompileStringRangeCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
-    Tcl_Obj *tmpObj;
-    int idx1, idx2, result;
+    int idx1, idx2;
 
     if (parsePtr->numWords != 4) {
 	return TCL_ERROR;
@@ -574,50 +983,13 @@ TclCompileStringRangeCmd(
     toTokenPtr = TokenAfter(fromTokenPtr);
 
     /*
-     * 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).
+     * Parse the two indices.
      */
 
-    tmpObj = Tcl_NewObj();
-    result = TCL_ERROR;
-    if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) {
-	if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) {
-	    if (idx1 >= 0) {
-		result = TCL_OK;
-	    }
-	} else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) {
-	    if (idx1 <= -2) {
-		result = TCL_OK;
-	    }
-	}
-    }
-    TclDecrRefCount(tmpObj);
-    if (result != TCL_OK) {
+    if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) {
 	goto nonConstantIndices;
     }
-
-    /*
-     * 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).
-     */
-
-    tmpObj = Tcl_NewObj();
-    result = TCL_ERROR;
-    if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) {
-	if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) {
-	    if (idx2 >= 0) {
-		result = TCL_OK;
-	    }
-	} else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) {
-	    if (idx2 <= -2) {
-		result = TCL_OK;
-	    }
-	}
-    }
-    TclDecrRefCount(tmpObj);
-    if (result != TCL_OK) {
+    if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) {
 	goto nonConstantIndices;
     }
 
@@ -631,7 +1003,7 @@ TclCompileStringRangeCmd(
 
     /*
      * Push the operands onto the stack and then the substring operation.
-     */    
+     */
 
   nonConstantIndices:
     CompileWord(envPtr, stringTokenPtr,			interp, 1);
@@ -640,6 +1012,320 @@ TclCompileStringRangeCmd(
     OP(			STR_RANGE);
     return TCL_OK;
 }
+
+int
+TclCompileStringReplaceCmd(
+    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, *valueTokenPtr, *replacementTokenPtr = NULL;
+    DefineLineInformation;	/* TIP #280 */
+    int idx1, idx2;
+
+    if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
+	return TCL_ERROR;
+    }
+    valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    if (parsePtr->numWords == 5) {
+	tokenPtr = TokenAfter(valueTokenPtr);
+	tokenPtr = TokenAfter(tokenPtr);
+	replacementTokenPtr = TokenAfter(tokenPtr);
+    }
+
+    /*
+     * Parse the indices. Will only compile special cases if both are
+     * constants and not an _integer_ less than zero (since we reserve
+     * negative indices here for end-relative indexing) or an end-based index
+     * greater than 'end' itself.
+     */
+
+    tokenPtr = TokenAfter(valueTokenPtr);
+    if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+	goto genericReplace;
+    }
+
+    tokenPtr = TokenAfter(tokenPtr);
+    if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+	goto genericReplace;
+    }
+
+    /*
+     * We handle these replacements specially: first character (where
+     * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything
+     * else and the semantics get rather screwy.
+     */
+
+    if (idx1 == 0 && idx2 == 0) {
+	int notEq, end;
+
+	/*
+	 * Just working with the first character.
+	 */
+
+	CompileWord(envPtr, valueTokenPtr, interp, 1);
+	if (replacementTokenPtr == NULL) {
+	    /* Drop first */
+	    OP44(	STR_RANGE_IMM, 1, INDEX_END);
+	    return TCL_OK;
+	}
+	/* Replace first */
+	CompileWord(envPtr, replacementTokenPtr, interp, 4);
+	OP4(		OVER, 1);
+	PUSH(		"");
+	OP(		STR_EQ);
+	JUMP1(		JUMP_FALSE, notEq);
+	OP(		POP);
+	JUMP1(		JUMP, end);
+	FIXJUMP1(notEq);
+	TclAdjustStackDepth(1, envPtr);
+	OP4(		REVERSE, 2);
+	OP44(		STR_RANGE_IMM, 1, INDEX_END);
+	OP1(		STR_CONCAT1, 2);
+	FIXJUMP1(end);
+	return TCL_OK;
+
+    } else if (idx1 == INDEX_END && idx2 == INDEX_END) {
+	int notEq, end;
+
+	/*
+	 * Just working with the last character.
+	 */
+
+	CompileWord(envPtr, valueTokenPtr, interp, 1);
+	if (replacementTokenPtr == NULL) {
+	    /* Drop last */
+	    OP44(	STR_RANGE_IMM, 0, INDEX_END-1);
+	    return TCL_OK;
+	}
+	/* Replace last */
+	CompileWord(envPtr, replacementTokenPtr, interp, 4);
+	OP4(		OVER, 1);
+	PUSH(		"");
+	OP(		STR_EQ);
+	JUMP1(		JUMP_FALSE, notEq);
+	OP(		POP);
+	JUMP1(		JUMP, end);
+	FIXJUMP1(notEq);
+	TclAdjustStackDepth(1, envPtr);
+	OP4(		REVERSE, 2);
+	OP44(		STR_RANGE_IMM, 0, INDEX_END-1);
+	OP4(		REVERSE, 2);
+	OP1(		STR_CONCAT1, 2);
+	FIXJUMP1(end);
+	return TCL_OK;
+
+    } else {
+	/*
+	 * Need to process indices at runtime. This could be because the
+	 * indices are not constants, or because we need to resolve them to
+	 * absolute indices to work out if a replacement is going to happen.
+	 * In any case, to runtime it is.
+	 */
+
+    genericReplace:
+	CompileWord(envPtr, valueTokenPtr, interp, 1);
+	tokenPtr = TokenAfter(valueTokenPtr);
+	CompileWord(envPtr, tokenPtr, interp, 2);
+	tokenPtr = TokenAfter(tokenPtr);
+	CompileWord(envPtr, tokenPtr, interp, 3);
+	if (replacementTokenPtr != NULL) {
+	    CompileWord(envPtr, replacementTokenPtr, interp, 4);
+	} else {
+	    PUSH(	"");
+	}
+	OP(		STR_REPLACE);
+	return TCL_OK;
+    }
+}
+
+int
+TclCompileStringTrimLCmd(
+    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;
+
+    if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr,			interp, 1);
+    if (parsePtr->numWords == 3) {
+	tokenPtr = TokenAfter(tokenPtr);
+	CompileWord(envPtr, tokenPtr,			interp, 2);
+    } else {
+	PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
+    }
+    OP(			STR_TRIM_LEFT);
+    return TCL_OK;
+}
+
+int
+TclCompileStringTrimRCmd(
+    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;
+
+    if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr,			interp, 1);
+    if (parsePtr->numWords == 3) {
+	tokenPtr = TokenAfter(tokenPtr);
+	CompileWord(envPtr, tokenPtr,			interp, 2);
+    } else {
+	PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
+    }
+    OP(			STR_TRIM_RIGHT);
+    return TCL_OK;
+}
+
+int
+TclCompileStringTrimCmd(
+    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;
+
+    if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr,			interp, 1);
+    if (parsePtr->numWords == 3) {
+	tokenPtr = TokenAfter(tokenPtr);
+	CompileWord(envPtr, tokenPtr,			interp, 2);
+    } else {
+	PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
+    }
+    OP(			STR_TRIM);
+    return TCL_OK;
+}
+
+int
+TclCompileStringToUpperCmd(
+    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;
+
+    if (parsePtr->numWords != 2) {
+	return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr,			interp, 1);
+    OP(			STR_UPPER);
+    return TCL_OK;
+}
+
+int
+TclCompileStringToLowerCmd(
+    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;
+
+    if (parsePtr->numWords != 2) {
+	return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr,			interp, 1);
+    OP(			STR_LOWER);
+    return TCL_OK;
+}
+
+int
+TclCompileStringToTitleCmd(
+    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;
+
+    if (parsePtr->numWords != 2) {
+	return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+    }
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    CompileWord(envPtr, tokenPtr,			interp, 1);
+    OP(			STR_TITLE);
+    return TCL_OK;
+}
+
+/*
+ * Support definitions for the [string is] compilation.
+ */
+
+static int
+UniCharIsAscii(
+    int character)
+{
+    return (character >= 0) && (character < 0x80);
+}
+
+static int
+UniCharIsHexDigit(
+    int character)
+{
+    return (character >= 0) && (character < 0x80) && isxdigit(character);
+}
+
+StringClassDesc const tclStringClassTable[] = {
+    {"alnum",	Tcl_UniCharIsAlnum},
+    {"alpha",	Tcl_UniCharIsAlpha},
+    {"ascii",	UniCharIsAscii},
+    {"control", Tcl_UniCharIsControl},
+    {"digit",	Tcl_UniCharIsDigit},
+    {"graph",	Tcl_UniCharIsGraph},
+    {"lower",	Tcl_UniCharIsLower},
+    {"print",	Tcl_UniCharIsPrint},
+    {"punct",	Tcl_UniCharIsPunct},
+    {"space",	Tcl_UniCharIsSpace},
+    {"upper",	Tcl_UniCharIsUpper},
+    {"word",	Tcl_UniCharIsWordChar},
+    {"xdigit",	UniCharIsHexDigit},
+    {NULL,	NULL}
+};
 
 /*
  *----------------------------------------------------------------------
@@ -750,7 +1436,7 @@ TclSubstCompile(
     /*
      * Tricky point! If the first token does not result in a *guaranteed* push
      * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it
-     * is possible to get to an INST_CONCAT1 or INST_DONE without enough
+     * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough
      * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for
      * identifying a script that could trigger this case.
      */
@@ -815,11 +1501,11 @@ TclSubstCompile(
 	}
 
 	while (count > 255) {
-	    OP1(		CONCAT1, 255);
+	    OP1(		STR_CONCAT1, 255);
 	    count -= 254;
 	}
 	if (count > 1) {
-	    OP1(		CONCAT1, count);
+	    OP1(		STR_CONCAT1, count);
 	    count = 1;
 	}
 
@@ -873,7 +1559,7 @@ TclSubstCompile(
 	OP(	END_CATCH);
 	OP(	RETURN_CODE_BRANCH);
 
-	/* ERROR -> reraise it */
+	/* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */
 	OP(	RETURN_STK);
 	OP(	NOP);
 
@@ -939,7 +1625,7 @@ TclSubstCompile(
 		    (int) (CurrentOffset(envPtr) - okFixup.codeOffset));
 	}
 	if (count > 1) {
-	    OP1(CONCAT1, count);
+	    OP1(STR_CONCAT1, count);
 	    count = 1;
 	}
 
@@ -952,11 +1638,11 @@ TclSubstCompile(
     }
 
     while (count > 255) {
-	OP1(	CONCAT1, 255);
+	OP1(	STR_CONCAT1, 255);
 	count -= 254;
     }
     if (count > 1) {
-	OP1(	CONCAT1, count);
+	OP1(	STR_CONCAT1, count);
     }
 
     Tcl_FreeParse(&parse);
@@ -1342,7 +2028,7 @@ IssueSwitchChainedTests(
     int foundDefault;		/* Flag to indicate whether a "default" clause
 				 * is present. */
     JumpFixup *fixupArray;	/* Array of forward-jump fixup records. */
-    int *fixupTargetArray;	/* Array of places for fixups to point at. */
+    unsigned int *fixupTargetArray; /* Array of places for fixups to point at. */
     int fixupCount;		/* Number of places to fix up. */
     int contFixIndex;		/* Where the first of the jumps due to a group
 				 * of continuation bodies starts, or -1 if
@@ -1409,7 +2095,7 @@ IssueSwitchChainedTests(
 		     */
 
 		    if (TclReToGlob(NULL, bodyToken[i]->start,
-			    bodyToken[i]->size, &ds, &exact) == TCL_OK) {
+			    bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){
 			simple = 1;
 			PushLiteral(envPtr, Tcl_DStringValue(&ds),
 				Tcl_DStringLength(&ds));
@@ -1496,7 +2182,7 @@ IssueSwitchChainedTests(
 	}
 
 	/*
-	 * Now do the actual compilation. Note that we do not use BODY() 
+	 * Now do the actual compilation. Note that we do not use BODY()
 	 * because we may have synthesized the tokens in a non-standard
 	 * pattern.
 	 */
@@ -1759,11 +2445,13 @@ IssueSwitchJumpTable(
  *	DupJumptableInfo: a copy of the jump-table
  *	FreeJumptableInfo: none
  *	PrintJumptableInfo: none
+ *	DisassembleJumptableInfo: none
  *
  * Side effects:
  *	DupJumptableInfo: allocates memory
  *	FreeJumptableInfo: releases memory
  *	PrintJumptableInfo: none
+ *	DisassembleJumptableInfo: none
  *
  *----------------------------------------------------------------------
  */
@@ -1826,6 +2514,30 @@ PrintJumptableInfo(
 		keyPtr, pcOffset + offset);
     }
 }
+
+static void
+DisassembleJumptableInfo(
+    ClientData clientData,
+    Tcl_Obj *dictObj,
+    ByteCode *codePtr,
+    unsigned int pcOffset)
+{
+    register JumptableInfo *jtPtr = clientData;
+    Tcl_Obj *mapping = Tcl_NewObj();
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch search;
+    const char *keyPtr;
+    int offset;
+
+    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
+    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
+	keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+	offset = PTR2INT(Tcl_GetHashValue(hPtr));
+	Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
+		Tcl_NewIntObj(offset));
+    }
+    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
+}
 
 /*
  *----------------------------------------------------------------------
@@ -1864,6 +2576,7 @@ TclCompileTailcallCmd(
     }
 
     /* make room for the nsObjPtr */
+    /* TODO: Doesn't this have to be a known value? */
     CompileWord(envPtr, tokenPtr, interp, 0);
     for (i=1 ; i<parsePtr->numWords ; i++) {
 	tokenPtr = TokenAfter(tokenPtr);
@@ -1927,7 +2640,7 @@ TclCompileThrowCmd(
     }
     CompileWord(envPtr, msgToken, interp, 2);
 
-    codeIsList = codeKnown && (TCL_OK == 
+    codeIsList = codeKnown && (TCL_OK ==
 	    Tcl_ListObjLength(interp, objPtr, &len));
     codeIsValid = codeIsList && (len != 0);
 
@@ -1964,7 +2677,7 @@ TclCompileThrowCmd(
 	OP(			LIST_LENGTH);
 	OP1(			JUMP_FALSE1, 16);
 	OP4(			LIST, 2);
-	OP44(			RETURN_IMM, 1, 0);
+	OP44(			RETURN_IMM, TCL_ERROR, 0);
 	TclAdjustStackDepth(2, envPtr);
 	OP(			POP);
 	OP(			POP);
@@ -1973,7 +2686,7 @@ TclCompileThrowCmd(
 	PUSH(			"type must be non-empty list");
 	PUSH(			"-errorcode {TCL OPERATION THROW BADEXCEPTION}");
     }
-    OP44(			RETURN_IMM, 1, 0);
+    OP44(			RETURN_IMM, TCL_ERROR, 0);
     return TCL_OK;
 }
 
@@ -2355,6 +3068,7 @@ IssueTryClausesInstructions(
 	if (!handlerTokens[i]) {
 	    forwardsNeedFixing = 1;
 	    JUMP4(			JUMP, forwardsToFix[i]);
+	    TclAdjustStackDepth(1, envPtr);
 	} else {
 	    int dontChangeOptions;
 
@@ -2395,7 +3109,7 @@ IssueTryClausesInstructions(
 	    TclAdjustStackDepth(-1, envPtr);
 	    FIXJUMP1(		dontChangeOptions);
 	    OP4(			REVERSE, 2);
-	    OP(				RETURN_STK);
+	    INVOKE(			RETURN_STK);
 	}
 
 	JUMP4(				JUMP, addrsToFix[i]);
@@ -2414,7 +3128,7 @@ IssueTryClausesInstructions(
     OP(					POP);
     LOAD(				optionsVar);
     LOAD(				resultVar);
-    OP(					RETURN_STK);
+    INVOKE(				RETURN_STK);
 
     /*
      * Fix all the jumps from taken clauses to here (which is the end of the
@@ -2723,7 +3437,7 @@ IssueTryClausesFinallyInstructions(
     FIXJUMP1(			finalOK);
     LOAD(				optionsVar);
     LOAD(				resultVar);
-    OP(					RETURN_STK);
+    INVOKE(				RETURN_STK);
 
     return TCL_OK;
 }
@@ -2782,7 +3496,7 @@ IssueTryFinallyInstructions(
     OP1(				JUMP1, 7);
     FIXJUMP1(		jumpOK);
     OP4(				REVERSE, 2);
-    OP(					RETURN_STK);
+    INVOKE(				RETURN_STK);
     return TCL_OK;
 }
 
@@ -2814,39 +3528,81 @@ TclCompileUnsetCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *varTokenPtr;
-    int isScalar, localIndex, numWords, flags, i;
-    Tcl_Obj *leadingWord;
+    int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
     DefineLineInformation;	/* TIP #280 */
 
     /* TODO: Consider support for compiling expanded args. */
-    numWords = parsePtr->numWords-1;
-    flags = 1;
-    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-    leadingWord = Tcl_NewObj();
-    if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
-	int len;
-	const char *bytes = Tcl_GetStringFromObj(leadingWord, &len);
 
-	if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
-	    flags = 0;
-	    varTokenPtr = TokenAfter(varTokenPtr);
-	    numWords--;
-	} else if (len == 2 && !strncmp("--", bytes, 2)) {
-	    varTokenPtr = TokenAfter(varTokenPtr);
-	    numWords--;
-	}
-    } else {
-	/*
-	 * Cannot guarantee that the first word is not '-nocomplain' at
-	 * evaluation with reasonable effort, so spill to interpreted version.
-	 */
+    /*
+     * Verify that all words - except the first non-option one - are known at
+     * compile time so that we can handle them without needing to do a nasty
+     * push/rotate. [Bug 3970f54c4e]
+     */
+
+    for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
+	Tcl_Obj *leadingWord = Tcl_NewObj();
+
+	varTokenPtr = TokenAfter(varTokenPtr);
+	if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
+	    TclDecrRefCount(leadingWord);
+
+	    /*
+	     * We can tolerate non-trivial substitutions in the first variable
+	     * to be unset. If a '--' or '-nocomplain' was present, anything
+	     * goes in that one place! (All subsequent variable names must be
+	     * constants since we don't want to have to push them all first.)
+	     */
+
+	    if (varCount == 0) {
+		if (haveFlags) {
+		    continue;
+		}
+
+		/*
+		 * In fact, we're OK as long as we're the first argument *and*
+		 * we provably don't start with a '-'. If that is true, then
+		 * even if everything else is varying, we still can't be a
+		 * flag. Otherwise we'll spill to runtime to place a limit on
+		 * the trickiness.
+		 */
 
+		if (varTokenPtr->type == TCL_TOKEN_WORD
+			&& varTokenPtr[1].type == TCL_TOKEN_TEXT
+			&& varTokenPtr[1].size > 0
+			&& varTokenPtr[1].start[0] != '-') {
+		    continue;
+		}
+	    }
+	    return TCL_ERROR;
+	}
+	if (varCount == 0) {
+	    const char *bytes;
+	    int len;
+
+	    bytes = Tcl_GetStringFromObj(leadingWord, &len);
+	    if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
+		flags = 0;
+		haveFlags++;
+	    } else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
+		haveFlags++;
+	    } else {
+		varCount++;
+	    }
+	} else {
+	    varCount++;
+	}
 	TclDecrRefCount(leadingWord);
-	return TCL_ERROR;
     }
-    TclDecrRefCount(leadingWord);
 
-    for (i=0 ; i<numWords ; i++) {
+    /*
+     * Issue instructions to unset each of the named variables.
+     */
+
+    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    for (i=0; i<haveFlags;i++) {
+	varTokenPtr = TokenAfter(varTokenPtr);
+    }
+    for (i=1+haveFlags ; i<parsePtr->numWords ; i++) {
 	/*
 	 * Decide if we can use a frame slot for the var/array name or if we
 	 * need to emit code to compute and push the name at runtime. We use a
@@ -2856,7 +3612,7 @@ TclCompileUnsetCmd(
 	 */
 
 	PushVarNameWord(interp, varTokenPtr, envPtr, 0,
-		&localIndex, &isScalar, 1);
+		&localIndex, &isScalar, i);
 
 	/*
 	 * Emit instructions to unset the variable.
@@ -3106,6 +3862,51 @@ TclCompileYieldCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileYieldToCmd --
+ *
+ *	Procedure called to compile the "yieldto" 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 "yieldto" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldToCmd(
+    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 = TokenAfter(parsePtr->tokenPtr);
+    int i;
+
+    if (parsePtr->numWords < 2) {
+	return TCL_ERROR;
+    }
+
+    OP(		NS_CURRENT);
+    for (i = 1 ; i < parsePtr->numWords ; i++) {
+	CompileWord(envPtr, tokenPtr, interp, i);
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+    OP4(	LIST, i);
+    OP(		YIELD_TO_INVOKE);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * CompileUnaryOpCmd --
  *
  *	Utility routine to compile the unary operator commands.