From 72901fb88ca266a88a78b0a34c4db3b3c386e367 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 2 Nov 2012 16:50:06 +0000
Subject: Work on compilation of [string is]. Hit some problem edge cases with
 differences in strictness of edge cases that will force a rethink ([string is
 boolean] is significantly more strict than Tcl_GetBooleanFromObj).

---
 generic/tclCmdMZ.c      |   2 +-
 generic/tclCompCmdsSZ.c | 190 ++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h        |   3 +
 3 files changed, 194 insertions(+), 1 deletion(-)

diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index de32fce..0526325 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3306,7 +3306,7 @@ TclInitStringCmd(
 	{"equal",	StringEqualCmd,	TclCompileStringEqualCmd, NULL, NULL, 0},
 	{"first",	StringFirstCmd,	TclCompileStringFirstCmd, NULL, NULL, 0},
 	{"index",	StringIndexCmd,	TclCompileStringIndexCmd, NULL, NULL, 0},
-	{"is",		StringIsCmd,	NULL, NULL, NULL, 0},
+	{"is",		StringIsCmd,	TclCompileStringIsCmd, NULL, NULL, 0},
 	{"last",	StringLastCmd,	NULL, NULL, NULL, 0},
 	{"length",	StringLenCmd,	TclCompileStringLenCmd, NULL, NULL, 0},
 	{"map",		StringMapCmd,	TclCompileStringMapCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 57cb992..b9309ec 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -451,6 +451,196 @@ TclCompileStringIndexCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileStringIsCmd --
+ *
+ *	Procedure called to compile the simplest and most common form of the
+ *	"string is" 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 is" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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);
+    int numWords = parsePtr->numWords;
+    enum IsType {
+	TypeBool, TypeBoolFalse, TypeBoolTrue,
+	TypeFloat,
+	TypeInteger, TypeNarrowInt, TypeWideInt,
+	TypeList /*, TypeDict */
+    };
+    enum IsType t;
+    JumpFixup jumpFixup;
+    int start, range;
+    int allowEmpty = 0;
+
+    if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+#define GotLiteral(tokenPtr,word) \
+    ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] &&	\
+	    strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
+
+    if (GotLiteral(tokenPtr, "boolean")) {
+	t = TypeBool;
+    } else if (GotLiteral(tokenPtr, "double")) {
+	t = TypeFloat;
+    } else if (GotLiteral(tokenPtr, "entier")) {
+	t = TypeInteger;
+    } else if (GotLiteral(tokenPtr, "false")) {
+	t = TypeBoolFalse;
+    } else if (GotLiteral(tokenPtr, "integer")) {
+	t = TypeNarrowInt;
+	return TCL_ERROR; // Not yet implemented
+    } else if (GotLiteral(tokenPtr, "list")) {
+	t = TypeList;
+    } else if (GotLiteral(tokenPtr, "true")) {
+	t = TypeBoolTrue;
+    } else if (GotLiteral(tokenPtr, "wideinteger")) {
+	t = TypeWideInt;
+	return TCL_ERROR; // Not yet implemented
+    } else {
+	/*
+	 * We don't handle character class checks in bytecode currently.
+	 */
+
+	return TCL_ERROR;
+    }
+    if (numWords != 3 && numWords != 4) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(tokenPtr);
+    if (numWords == 3) {
+	allowEmpty = (t != TypeList);
+    } else {
+	if (!GotLiteral(tokenPtr, "-strict")) {
+	    return TCL_ERROR;
+	}
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+#undef GotLiteral
+
+    /*
+     * Push the word to check.
+     */
+
+    CompileWord(envPtr, tokenPtr, interp, numWords-1);
+
+    /*
+     * Next, do the type check. First, we push a catch range; most of the
+     * type-check operations throw an exception on failure.
+     */
+
+    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    start = 0;
+    TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
+    ExceptionRangeStarts(envPtr, range);
+
+    /*
+     * Issue the type-check itself for the specific type.
+     */
+
+    switch (t) {
+    case TypeBool:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_LNOT,			envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    case TypeBoolFalse:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	start = CurrentOffset(envPtr);
+	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);
+	break;
+    case TypeBoolTrue:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	start = CurrentOffset(envPtr);
+	TclEmitInstInt1(	INST_JUMP_FALSE1, 0,		envPtr);
+	break;
+    case TypeFloat:
+	/*
+	 * Careful! Preserve behavior of NaN which is a double (that is, true
+	 * for the purposes of a type check) but most math ops fail on it. The
+	 * key is that it is not == to itself (and is the only value which
+	 * this is true for).
+	 */
+
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_NEQ,			envPtr);
+	TclEmitInstInt1(	INST_JUMP_TRUE1, 5,		envPtr);
+
+	/*
+	 * Type check for all other double values.
+	 */
+
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_UMINUS,			envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    case TypeInteger:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_BITNOT,			envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    case TypeNarrowInt:
+	Tcl_Panic("not yet implemented");
+    case TypeWideInt:
+	Tcl_Panic("not yet implemented");
+    case TypeList:
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	break;
+    }
+
+    /*
+     * Based on whether the exception was thrown (or conditional branch taken,
+     * in the case of true/false checks), push the correct boolean value. This
+     * is also where we deal with what happens with empty values in non-strict
+     * mode.
+     */
+
+    ExceptionRangeEnds(envPtr, range);
+    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
+    PushLiteral(envPtr, "1", 1);
+    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+    ExceptionRangeTarget(envPtr, range, catchOffset);
+    if (start != 0) {
+	TclStoreInt1AtPtr(CurrentOffset(envPtr) - start,
+		envPtr->codeStart + start + 1);
+    }
+    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    if (allowEmpty) {
+	PushLiteral(envPtr, "", 0);
+	TclEmitOpcode(		INST_STR_EQ,			envPtr);
+    } else {
+	TclEmitOpcode(		INST_POP,			envPtr);
+	PushLiteral(envPtr, "0", 1);
+    }
+    TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileStringMatchCmd --
  *
  *	Procedure called to compile the simplest and most common form of the
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1fffa1f..e513a6e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3647,6 +3647,9 @@ MODULE_SCOPE int	TclCompileStringFirstCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileStringIndexCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileStringIsCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileStringLenCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From c3ba561b42a9a5ebac6660b70f30f37c923e0551 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 2 Jan 2014 15:30:53 +0000
Subject: redevelop code to have more in common with the interpreted [string
 is] and to remove non-working types

---
 generic/tclCompCmdsSZ.c | 147 +++++++++++++++++++++++++-----------------------
 1 file changed, 78 insertions(+), 69 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 440b5bf..06cca50 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -435,56 +435,59 @@ TclCompileStringIsCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    int numWords = parsePtr->numWords;
-    enum IsType {
-	TypeBool, TypeBoolFalse, TypeBoolTrue,
-	TypeFloat,
-	TypeInteger, TypeNarrowInt, TypeWideInt,
-	TypeList /*, TypeDict */
+    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
     };
-    enum IsType t;
     JumpFixup jumpFixup;
-    int start, range;
-    int allowEmpty = 0;
+    int t, range, allowEmpty = 0;
+    Tcl_Obj *isClass;
 
-    if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+    if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
 	return TCL_ERROR;
     }
-#define GotLiteral(tokenPtr,word) \
-    ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] &&	\
-	    strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
-
-    if (GotLiteral(tokenPtr, "boolean")) {
-	t = TypeBool;
-    } else if (GotLiteral(tokenPtr, "double")) {
-	t = TypeFloat;
-    } else if (GotLiteral(tokenPtr, "entier")) {
-	t = TypeInteger;
-    } else if (GotLiteral(tokenPtr, "false")) {
-	t = TypeBoolFalse;
-    } else if (GotLiteral(tokenPtr, "integer")) {
-	t = TypeNarrowInt;
-	return TCL_ERROR; // Not yet implemented
-    } else if (GotLiteral(tokenPtr, "list")) {
-	t = TypeList;
-    } else if (GotLiteral(tokenPtr, "true")) {
-	t = TypeBoolTrue;
-    } else if (GotLiteral(tokenPtr, "wideinteger")) {
-	t = TypeWideInt;
-	return TCL_ERROR; // Not yet implemented
-    } else {
-	/*
-	 * We don't handle character class checks in bytecode currently.
-	 */
-
+    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;
     }
-    if (numWords != 3 && numWords != 4) {
+    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 (numWords == 3) {
-	allowEmpty = (t != TypeList);
+    if (parsePtr->numWords == 3) {
+	allowEmpty = (t != STR_IS_LIST);
     } else {
 	if (!GotLiteral(tokenPtr, "-strict")) {
 	    return TCL_ERROR;
@@ -494,18 +497,47 @@ TclCompileStringIsCmd(
 #undef GotLiteral
 
     /*
+     * Some types are not currently handled. Character classes are a prime
+     * example of this.
+     */
+
+    switch (t) {
+    case STR_IS_ALNUM:
+    case STR_IS_ALPHA:
+    case STR_IS_ASCII:
+    case STR_IS_CONTROL:
+    case STR_IS_DIGIT:
+    case STR_IS_GRAPH:
+    case STR_IS_LOWER:
+    case STR_IS_PRINT:
+    case STR_IS_PUNCT:
+    case STR_IS_SPACE:
+    case STR_IS_UPPER:
+    case STR_IS_WORD:
+    case STR_IS_XDIGIT:
+	return TCL_ERROR;
+
+    case STR_IS_BOOL:
+    case STR_IS_FALSE:
+    case STR_IS_INT:
+    case STR_IS_TRUE:
+    case STR_IS_WIDE:
+	/* Not yet implemented */
+	return TCL_ERROR;
+    }
+
+    /*
      * Push the word to check.
      */
 
-    CompileWord(envPtr, tokenPtr, interp, numWords-1);
+    CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 
     /*
      * Next, do the type check. First, we push a catch range; most of the
      * type-check operations throw an exception on failure.
      */
 
-    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-    start = 0;
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
     ExceptionRangeStarts(envPtr, range);
 
@@ -514,22 +546,7 @@ TclCompileStringIsCmd(
      */
 
     switch (t) {
-    case TypeBool:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_LNOT,			envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
-	break;
-    case TypeBoolFalse:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	start = CurrentOffset(envPtr);
-	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);
-	break;
-    case TypeBoolTrue:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	start = CurrentOffset(envPtr);
-	TclEmitInstInt1(	INST_JUMP_FALSE1, 0,		envPtr);
-	break;
-    case TypeFloat:
+    case STR_IS_DOUBLE:
 	/*
 	 * Careful! Preserve behavior of NaN which is a double (that is, true
 	 * for the purposes of a type check) but most math ops fail on it. The
@@ -550,16 +567,12 @@ TclCompileStringIsCmd(
 	TclEmitOpcode(		INST_UMINUS,			envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
 	break;
-    case TypeInteger:
+    case STR_IS_ENTIER:
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_BITNOT,			envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
 	break;
-    case TypeNarrowInt:
-	Tcl_Panic("not yet implemented");
-    case TypeWideInt:
-	Tcl_Panic("not yet implemented");
-    case TypeList:
+    case STR_IS_LIST:
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
@@ -579,10 +592,6 @@ TclCompileStringIsCmd(
     PushLiteral(envPtr, "1", 1);
     TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
     ExceptionRangeTarget(envPtr, range, catchOffset);
-    if (start != 0) {
-	TclStoreInt1AtPtr(CurrentOffset(envPtr) - start,
-		envPtr->codeStart + start + 1);
-    }
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
     if (allowEmpty) {
 	PushLiteral(envPtr, "", 0);
-- 
cgit v0.12


From b9663aff14aff96677a1252092a006ae19f81a8c Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 8 Jan 2014 11:04:44 +0000
Subject: Make DEFAULT_TRIM_SET a MODULE_SCOPE string constant, so its value
 can be shared in tclCmdMZ.o and TclCompCmdsSZ.o and it no longer pollutes the
 tclStringTrim.h header file.

---
 generic/tclCmdMZ.c      | 45 +++++++++++++++++++++++++++++++++++++++------
 generic/tclCompCmdsSZ.c |  6 +++---
 generic/tclStringTrim.h | 27 +--------------------------
 3 files changed, 43 insertions(+), 35 deletions(-)

diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d477216..c02cd1a 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -32,6 +32,39 @@ static int		TryPostHandler(ClientData data[], Tcl_Interp *interp,
 			    int result);
 static int		UniCharIsAscii(int character);
 static int		UniCharIsHexDigit(int character);
+
+/*
+ * Default set of characters to trim in [string trim] and friends. This is a
+ * UTF-8 literal string containing all Unicode space characters [TIP #413]
+ */
+
+const char tclDefaultTrimSet[] = 
+	"\x09\x0a\x0b\x0c\x0d " /* ASCII */
+	"\xc0\x80" /*     nul (U+0000) */
+	"\xc2\x85" /*     next line (U+0085) */
+	"\xc2\xa0" /*     non-breaking space (U+00a0) */
+	"\xe1\x9a\x80" /* ogham space mark (U+1680) */
+	"\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */
+	"\xe2\x80\x80" /* en quad (U+2000) */
+	"\xe2\x80\x81" /* em quad (U+2001) */
+	"\xe2\x80\x82" /* en space (U+2002) */
+	"\xe2\x80\x83" /* em space (U+2003) */
+	"\xe2\x80\x84" /* three-per-em space (U+2004) */
+	"\xe2\x80\x85" /* four-per-em space (U+2005) */
+	"\xe2\x80\x86" /* six-per-em space (U+2006) */
+	"\xe2\x80\x87" /* figure space (U+2007) */
+	"\xe2\x80\x88" /* punctuation space (U+2008) */
+	"\xe2\x80\x89" /* thin space (U+2009) */
+	"\xe2\x80\x8a" /* hair space (U+200a) */
+	"\xe2\x80\x8b" /* zero width space (U+200b) */
+	"\xe2\x80\xa8" /* line separator (U+2028) */
+	"\xe2\x80\xa9" /* paragraph separator (U+2029) */
+	"\xe2\x80\xaf" /* narrow no-break space (U+202f) */
+	"\xe2\x81\x9f" /* medium mathematical space (U+205f) */
+	"\xe2\x81\xa0" /* word joiner (U+2060) */
+	"\xe3\x80\x80" /* ideographic space (U+3000) */
+	"\xef\xbb\xbf" /* zero width no-break space (U+feff) */
+;
 
 /*
  *----------------------------------------------------------------------
@@ -3158,8 +3191,8 @@ StringTrimCmd(
     if (objc == 3) {
 	string2 = TclGetStringFromObj(objv[2], &length2);
     } else if (objc == 2) {
-	string2 = DEFAULT_TRIM_SET;
-	length2 = strlen(DEFAULT_TRIM_SET);
+	string2 = tclDefaultTrimSet;
+	length2 = strlen(tclDefaultTrimSet);
     } else {
 	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
 	return TCL_ERROR;
@@ -3206,8 +3239,8 @@ StringTrimLCmd(
     if (objc == 3) {
 	string2 = TclGetStringFromObj(objv[2], &length2);
     } else if (objc == 2) {
-	string2 = DEFAULT_TRIM_SET;
-	length2 = strlen(DEFAULT_TRIM_SET);
+	string2 = tclDefaultTrimSet;
+	length2 = strlen(tclDefaultTrimSet);
     } else {
 	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
 	return TCL_ERROR;
@@ -3252,8 +3285,8 @@ StringTrimRCmd(
     if (objc == 3) {
 	string2 = TclGetStringFromObj(objv[2], &length2);
     } else if (objc == 2) {
-	string2 = DEFAULT_TRIM_SET;
-	length2 = strlen(DEFAULT_TRIM_SET);
+	string2 = tclDefaultTrimSet;
+	length2 = strlen(tclDefaultTrimSet);
     } else {
 	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
 	return TCL_ERROR;
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 0f2790f..c54a06a 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -810,7 +810,7 @@ TclCompileStringTrimLCmd(
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr,			interp, 2);
     } else {
-	PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+	PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
     }
     OP(			STR_TRIM_LEFT);
     return TCL_OK;
@@ -838,7 +838,7 @@ TclCompileStringTrimRCmd(
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr,			interp, 2);
     } else {
-	PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+	PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
     }
     OP(			STR_TRIM_RIGHT);
     return TCL_OK;
@@ -866,7 +866,7 @@ TclCompileStringTrimCmd(
 	tokenPtr = TokenAfter(tokenPtr);
 	CompileWord(envPtr, tokenPtr,			interp, 2);
     } else {
-	PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+	PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
     }
     OP(			STR_TRIM);
     return TCL_OK;
diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h
index 669f10b..030e4ec 100644
--- a/generic/tclStringTrim.h
+++ b/generic/tclStringTrim.h
@@ -23,32 +23,7 @@
  * UTF-8 literal string containing all Unicode space characters. [TIP #413]
  */
 
-#define DEFAULT_TRIM_SET \
-	"\x09\x0a\x0b\x0c\x0d " /* ASCII */\
-	"\xc0\x80" /*     nul (U+0000) */\
-	"\xc2\x85" /*     next line (U+0085) */\
-	"\xc2\xa0" /*     non-breaking space (U+00a0) */\
-	"\xe1\x9a\x80" /* ogham space mark (U+1680) */ \
-	"\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\
-	"\xe2\x80\x80" /* en quad (U+2000) */\
-	"\xe2\x80\x81" /* em quad (U+2001) */\
-	"\xe2\x80\x82" /* en space (U+2002) */\
-	"\xe2\x80\x83" /* em space (U+2003) */\
-	"\xe2\x80\x84" /* three-per-em space (U+2004) */\
-	"\xe2\x80\x85" /* four-per-em space (U+2005) */\
-	"\xe2\x80\x86" /* six-per-em space (U+2006) */\
-	"\xe2\x80\x87" /* figure space (U+2007) */\
-	"\xe2\x80\x88" /* punctuation space (U+2008) */\
-	"\xe2\x80\x89" /* thin space (U+2009) */\
-	"\xe2\x80\x8a" /* hair space (U+200a) */\
-	"\xe2\x80\x8b" /* zero width space (U+200b) */\
-	"\xe2\x80\xa8" /* line separator (U+2028) */\
-	"\xe2\x80\xa9" /* paragraph separator (U+2029) */\
-	"\xe2\x80\xaf" /* narrow no-break space (U+202f) */\
-	"\xe2\x81\x9f" /* medium mathematical space (U+205f) */\
-	"\xe2\x81\xa0" /* word joiner (U+2060) */\
-	"\xe3\x80\x80" /* ideographic space (U+3000) */\
-	"\xef\xbb\xbf" /* zero width no-break space (U+feff) */
+MODULE_SCOPE const char tclDefaultTrimSet[];
 
 /*
  * The whitespace trimming set used when [concat]enating. This is a subset of
-- 
cgit v0.12


From acf1cebeab93607fc83206e77534b5fada8726ef Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 9 Jan 2014 10:49:04 +0000
Subject: use compact form

---
 generic/tclCompCmdsSZ.c | 51 ++++++++++++++++++++++++-------------------------
 1 file changed, 25 insertions(+), 26 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 06cca50..345dd9f 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -451,8 +451,7 @@ TclCompileStringIsCmd(
 	STR_IS_TRUE,	STR_IS_UPPER,	STR_IS_WIDE,	STR_IS_WORD,
 	STR_IS_XDIGIT
     };
-    JumpFixup jumpFixup;
-    int t, range, allowEmpty = 0;
+    int t, range, allowEmpty = 0, end;
     Tcl_Obj *isClass;
 
     if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
@@ -538,7 +537,7 @@ TclCompileStringIsCmd(
      */
 
     range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
-    TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
+    OP4(		BEGIN_CATCH4, range);
     ExceptionRangeStarts(envPtr, range);
 
     /*
@@ -554,28 +553,28 @@ TclCompileStringIsCmd(
 	 * this is true for).
 	 */
 
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_NEQ,			envPtr);
-	TclEmitInstInt1(	INST_JUMP_TRUE1, 5,		envPtr);
+	OP(		DUP);
+	OP(		DUP);
+	OP(		NEQ);
+	OP1(		JUMP_TRUE1, 5);
 
 	/*
 	 * Type check for all other double values.
 	 */
 
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_UMINUS,			envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
+	OP(		DUP);
+	OP(		UMINUS);
+	OP(		POP);
 	break;
     case STR_IS_ENTIER:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_BITNOT,			envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
+	OP(		DUP);
+	OP(		BITNOT);
+	OP(		POP);
 	break;
     case STR_IS_LIST:
-	TclEmitOpcode(		INST_DUP,			envPtr);
-	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
-	TclEmitOpcode(		INST_POP,			envPtr);
+	OP(		DUP);
+	OP(		LIST_LENGTH);
+	OP(		POP);
 	break;
     }
 
@@ -587,20 +586,20 @@ TclCompileStringIsCmd(
      */
 
     ExceptionRangeEnds(envPtr, range);
-    TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    TclEmitOpcode(		INST_POP,			envPtr);
-    PushLiteral(envPtr, "1", 1);
-    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+    OP(			END_CATCH);
+    OP(			POP);
+    PUSH(		"1");
+    JUMP1(		JUMP, end);
     ExceptionRangeTarget(envPtr, range, catchOffset);
-    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    OP(			END_CATCH);
     if (allowEmpty) {
-	PushLiteral(envPtr, "", 0);
-	TclEmitOpcode(		INST_STR_EQ,			envPtr);
+	PUSH(		"");
+	OP(		STR_EQ);
     } else {
-	TclEmitOpcode(		INST_POP,			envPtr);
-	PushLiteral(envPtr, "0", 1);
+	OP(		POP);
+	PUSH(		"0");
     }
-    TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+    FIXJUMP1(	end);
     return TCL_OK;
 }
 
-- 
cgit v0.12


From c3c6e803684022dcc788ddbfc4a59a6d0dfde102 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 10 Jan 2014 15:58:41 +0000
Subject: a different approach

---
 generic/tclAssembly.c   |   4 +-
 generic/tclCompCmdsSZ.c | 150 ++++++++++++++++++++++++++----------------------
 generic/tclCompile.c    |   4 ++
 generic/tclCompile.h    |   4 +-
 generic/tclExecute.c    |   8 +++
 5 files changed, 98 insertions(+), 72 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..70379c6 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"nop",		ASSEM_1BYTE,	INST_NOP,		0,	0},
     {"not",		ASSEM_1BYTE,	INST_LNOT,		1,	1},
     {"nsupvar",		ASSEM_LVT4,	INST_NSUPVAR,		2,	1},
+    {"numericType",	ASSEM_1BYTE,	INST_NUM_TYPE,		1,	1},
     {"originCmd",	ASSEM_1BYTE,	INST_ORIGIN_COMMAND,	1,	1},
     {"over",		ASSEM_OVER,	INST_OVER,		INT_MIN,-1-1},
     {"pop",		ASSEM_1BYTE,	INST_POP,		1,	0},
@@ -516,7 +517,8 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_RESOLVE_COMMAND,					/* 154 */
     INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT,	/* 166-168 */
     INST_CONCAT_STK,						/* 169 */
-    INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE		/* 170-172 */
+    INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE,		/* 170-172 */
+    INST_NUM_TYPE						/* 180 */
 };
 
 /*
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 345dd9f..1436a20 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -500,7 +500,7 @@ TclCompileStringIsCmd(
      * example of this.
      */
 
-    switch (t) {
+    switch ((enum isClasses) t) {
     case STR_IS_ALNUM:
     case STR_IS_ALPHA:
     case STR_IS_ASCII:
@@ -514,93 +514,103 @@ TclCompileStringIsCmd(
     case STR_IS_UPPER:
     case STR_IS_WORD:
     case STR_IS_XDIGIT:
+	/* Not yet implemented */
 	return TCL_ERROR;
 
     case STR_IS_BOOL:
     case STR_IS_FALSE:
-    case STR_IS_INT:
     case STR_IS_TRUE:
-    case STR_IS_WIDE:
 	/* Not yet implemented */
 	return TCL_ERROR;
-    }
-
-    /*
-     * Push the word to check.
-     */
-
-    CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 
-    /*
-     * Next, do the type check. First, we push a catch range; most of the
-     * type-check operations throw an exception on failure.
-     */
-
-    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
-    OP4(		BEGIN_CATCH4, range);
-    ExceptionRangeStarts(envPtr, range);
-
-    /*
-     * Issue the type-check itself for the specific type.
-     */
+    case STR_IS_DOUBLE: {
+	int satisfied, isEmpty;
 
-    switch (t) {
-    case STR_IS_DOUBLE:
-	/*
-	 * Careful! Preserve behavior of NaN which is a double (that is, true
-	 * for the purposes of a type check) but most math ops fail on it. The
-	 * key is that it is not == to itself (and is the only value which
-	 * this is true for).
-	 */
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	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;
+    }
 
-	OP(		DUP);
-	OP(		DUP);
-	OP(		NEQ);
-	OP1(		JUMP_TRUE1, 5);
+    case STR_IS_INT:
+    case STR_IS_WIDE:
+    case STR_IS_ENTIER:
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	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);
+	}
 
-	/*
-	 * Type check for all other double values.
-	 */
+	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;
 
-	OP(		DUP);
-	OP(		UMINUS);
-	OP(		POP);
-	break;
-    case STR_IS_ENTIER:
-	OP(		DUP);
-	OP(		BITNOT);
-	OP(		POP);
-	break;
     case STR_IS_LIST:
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+	OP4(		BEGIN_CATCH4, range);
+	ExceptionRangeStarts(envPtr, range);
 	OP(		DUP);
 	OP(		LIST_LENGTH);
 	OP(		POP);
-	break;
-    }
-
-    /*
-     * Based on whether the exception was thrown (or conditional branch taken,
-     * in the case of true/false checks), push the correct boolean value. This
-     * is also where we deal with what happens with empty values in non-strict
-     * mode.
-     */
-
-    ExceptionRangeEnds(envPtr, range);
-    OP(			END_CATCH);
-    OP(			POP);
-    PUSH(		"1");
-    JUMP1(		JUMP, end);
-    ExceptionRangeTarget(envPtr, range, catchOffset);
-    OP(			END_CATCH);
-    if (allowEmpty) {
-	PUSH(		"");
-	OP(		STR_EQ);
-    } else {
+	ExceptionRangeEnds(envPtr, range);
+	ExceptionRangeTarget(envPtr, range, catchOffset);
 	OP(		POP);
-	PUSH(		"0");
+	OP(		PUSH_RETURN_CODE);
+	OP(		END_CATCH);
+	OP(		LNOT);
+	return TCL_OK;
     }
-    FIXJUMP1(	end);
-    return TCL_OK;
+    return TCL_ERROR;
 }
 
 int
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ee67e24..c01571f 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -621,6 +621,10 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
 
+    {"numericType",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Pushes the numeric type code of the word at the top of the stack.
+	 * Stack:  ... value => ... typeCode */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6ecadf4..6bf5daf 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -792,8 +792,10 @@ typedef struct ByteCode {
 
 #define INST_TCLOO_NEXT			179
 
+#define INST_NUM_TYPE			180
+
 /* The last opcode */
-#define LAST_INST_OPCODE		179
+#define LAST_INST_OPCODE		180
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5b42124..2707ec1 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5776,6 +5776,14 @@ TEBCresume(
 	int type1, type2;
 	long l1, l2, lResult;
 
+    case INST_NUM_TYPE:
+	if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
+	    type1 = 0;
+	}
+	TclNewIntObj(objResultPtr, type1);
+	TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
+	NEXT_INST_F(1, 1, 1);
+
     case INST_EQ:
     case INST_NEQ:
     case INST_LT:
-- 
cgit v0.12


From aa2c40934df3fdefbb39338f7eef44e79c3c551e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 13 Jan 2014 08:06:43 +0000
Subject: extend [string is] to booleans

---
 generic/tclAssembly.c   |  1 +
 generic/tclCompCmdsSZ.c | 51 +++++++++++++++++++++++++++++++++++++++++++++----
 generic/tclCompile.c    |  3 +++
 generic/tclCompile.h    |  3 ++-
 generic/tclExecute.c    | 11 +++++++++++
 5 files changed, 64 insertions(+), 5 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 70379c6..f10bca8 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -478,6 +478,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"tclooIsObject",	ASSEM_1BYTE,	INST_TCLOO_IS_OBJECT,	1,	1},
     {"tclooNamespace",	ASSEM_1BYTE,	INST_TCLOO_NS,		1,	1},
     {"tclooSelf",	ASSEM_1BYTE,	INST_TCLOO_SELF,	0,	1},
+    {"tryCvtToBoolean",	ASSEM_1BYTE,	INST_TRY_CVT_TO_BOOLEAN,1,	2},
     {"tryCvtToNumeric",	ASSEM_1BYTE,	INST_TRY_CVT_TO_NUMERIC,1,	1},
     {"uminus",		ASSEM_1BYTE,	INST_UMINUS,		1,	1},
     {"unset",		ASSEM_BOOL_LVT4,INST_UNSET_SCALAR,	0,	0},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 1436a20..91bb94c 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -514,14 +514,57 @@ TclCompileStringIsCmd(
     case STR_IS_UPPER:
     case STR_IS_WORD:
     case STR_IS_XDIGIT:
-	/* Not yet implemented */
-	return TCL_ERROR;
+	return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 
     case STR_IS_BOOL:
     case STR_IS_FALSE:
     case STR_IS_TRUE:
-	/* Not yet implemented */
-	return TCL_ERROR;
+	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+	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;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c01571f..39fa241 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -624,6 +624,9 @@ InstructionDesc const tclInstructionTable[] = {
     {"numericType",	 1,	0,	  0,	{OPERAND_NONE}},
 	/* Pushes the numeric type code of the word at the top of the stack.
 	 * Stack:  ... value => ... typeCode */
+    {"tryCvtToBoolean",	 1,	+1,	  0,	{OPERAND_NONE}},
+	/* Try converting stktop to boolean if possible. No errors.
+	 * Stack:  ... value => ... value isStrictBool */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6bf5daf..a08a93a 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -793,9 +793,10 @@ typedef struct ByteCode {
 #define INST_TCLOO_NEXT			179
 
 #define INST_NUM_TYPE			180
+#define INST_TRY_CVT_TO_BOOLEAN		181
 
 /* The last opcode */
-#define LAST_INST_OPCODE		180
+#define LAST_INST_OPCODE		181
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2707ec1..989b7b6 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6461,6 +6461,17 @@ TEBCresume(
      * -----------------------------------------------------------------
      */
 
+    case INST_TRY_CVT_TO_BOOLEAN:
+	valuePtr = OBJ_AT_TOS;
+	if (valuePtr->typePtr == &tclBooleanType) {
+	    objResultPtr = TCONST(1);
+	} else {
+	    int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
+	    objResultPtr = TCONST(result);
+	}
+	TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
+	NEXT_INST_F(1, 0, 1);
+
     case INST_BREAK:
 	/*
 	DECACHE_STACK_INFO();
-- 
cgit v0.12


From e0791bfa1b98a28520902dbb5018ffdcb5925860 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 15 Jan 2014 19:04:52 +0000
Subject: [2992970] Restore the safety of Tcl_AppendObjToObj(x, x) for
 bytearrays. Also moves overflow checking to TclAppendBytesToByteArray() and
 adds the ability to call TABTBA() with bytes==NULL, for appending unspecified
 bytes.  That is, the string grows, but the new bytes are of undetermined
 value.  Like Tcl_NewByteArrayObj(NULL, length) this option is useful for
 manipulating buffers.  The TABTBA growth algorithm is also enhanced a bit,
 copying over a fuller implementation from GrowStringBuffer() in
 tclStringObj.c

---
 generic/tclBinary.c    | 74 ++++++++++++++++++++++----------------------------
 generic/tclStringObj.c | 42 ++++++++++++++++++++--------
 2 files changed, 64 insertions(+), 52 deletions(-)

diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 4e977f2..981f174 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -610,9 +610,7 @@ UpdateStringOfByteArray(
  *
  *	This function appends an array of bytes to a byte array object. Note
  *	that the object *must* be unshared, and the array of bytes *must not*
- *	refer to the object being appended to.  Also the caller must have
- *	already checked that the final length of the bytearray after the
- *	append operations is complete will not overflow the int range.
+ *	refer to the object being appended to.
  *
  * Results:
  *	None.
@@ -631,6 +629,7 @@ TclAppendBytesToByteArray(
     int len)
 {
     ByteArray *byteArrayPtr;
+    int needed;
 
     if (Tcl_IsShared(objPtr)) {
 	Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
@@ -639,64 +638,57 @@ TclAppendBytesToByteArray(
 	Tcl_Panic("%s must be called with definite number of bytes to append",
 		"TclAppendBytesToByteArray");
     }
+    if (len == 0) {
+	/* Append zero bytes is a no-op. */
+	return;
+    }
     if (objPtr->typePtr != &tclByteArrayType) {
 	SetByteArrayFromAny(NULL, objPtr);
     }
     byteArrayPtr = GET_BYTEARRAY(objPtr);
 
+    if (len > INT_MAX - byteArrayPtr->used) {
+	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+    }
+
+    needed = byteArrayPtr->used + len;
     /*
      * If we need to, resize the allocated space in the byte array.
      */
 
-    if (byteArrayPtr->used + len > byteArrayPtr->allocated) {
-	unsigned int attempt, used = byteArrayPtr->used;
-	ByteArray *tmpByteArrayPtr = NULL;
+    if (needed > byteArrayPtr->allocated) {
+	ByteArray *ptr = NULL;
+	int attempt;
 
-	attempt = byteArrayPtr->allocated;
-	if (attempt < 1) {
-	    /*
-	     * No allocated bytes, so must be none used too. We use this
-	     * method to calculate how many bytes to allocate because we can
-	     * end up with a zero-length buffer otherwise, when doubling can
-	     * cause trouble. [Bug 3067036]
-	     */
-
-	    attempt = len + 1;
-	} else {
-	    do {
-		attempt *= 2;
-	    } while (attempt < used+len);
+	if (needed <= INT_MAX/2) {
+	    /* Try to allocate double the total space that is needed. */
+	    attempt = 2 * needed;
+	    ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
 	}
+	if (ptr == NULL) {
+	    /* Try to allocate double the increment that is needed (plus). */
+	    unsigned int limit = INT_MAX - needed;
+	    unsigned int extra = len + TCL_MIN_GROWTH;
+	    int growth = (int) ((extra > limit) ? limit : extra);
 
-	if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) {
-	    tmpByteArrayPtr = attemptckrealloc(byteArrayPtr,
-		    BYTEARRAY_SIZE(attempt));
+	    attempt = needed + growth;
+	    ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
 	}
-
-	if (tmpByteArrayPtr == NULL) {
-	    attempt = used + len;
-	    if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) {
-		Tcl_Panic("attempt to allocate a bigger buffer than we can handle");
-	    }
-	    tmpByteArrayPtr = ckrealloc(byteArrayPtr,
-		    BYTEARRAY_SIZE(attempt));
+	if (ptr == NULL) {
+	    /* Last chance: Try to allocate exactly what is needed. */
+	    attempt = needed;
+	    ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
 	}
-
-	byteArrayPtr = tmpByteArrayPtr;
+	byteArrayPtr = ptr;
 	byteArrayPtr->allocated = attempt;
-	byteArrayPtr->used = used;
 	SET_BYTEARRAY(objPtr, byteArrayPtr);
     }
 
-    /*
-     * Do the append if there's any point.
-     */
-
-    if (len > 0) {
+    if (bytes) {
 	memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
-	byteArrayPtr->used += len;
-	TclInvalidateStringRep(objPtr);
     }
+    byteArrayPtr->used += len;
+    TclInvalidateStringRep(objPtr);
 }
 
 /*
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index e495c2e..1512f0c 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1281,23 +1281,43 @@ Tcl_AppendObjToObj(
 
     if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
 	    && TclIsPureByteArray(appendObjPtr)) {
-	unsigned char *bytesSrc;
-	int lengthSrc, lengthTotal;
+	int lengthSrc;
 
 	/*
-	 * We do not assume that objPtr and appendObjPtr must be distinct!
-	 * This makes this code a bit more complex than it otherwise would be,
-	 * but in turn makes it much safer.
+	 * You might expect the code here to be
+	 *
+
+	    bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length);
+	    TclAppendBytesToByteArray(objPtr, bytes, length);
+
+	 *
+	 * and essentially all of the time that would be fine.  However,
+	 * it would run into trouble in the case where objPtr and
+	 * appendObjPtr point to the same thing.  That may never be a
+	 * good idea.  It seems to violate Copy On Write, and we don't
+	 * have any tests for the situation, since making any Tcl commands
+	 * that call Tcl_AppendObjToObj() do that appears impossible
+	 * (They honor Copy On Write!).  For the sake of extensions that
+	 * go off into that realm, though, here's a more complex approach
+	 * that can handle all the cases.
 	 */
 
+	/* Get lengths */
 	(void) Tcl_GetByteArrayFromObj(objPtr, &length);
 	(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);
-	lengthTotal = length + lengthSrc;
-	if (((length > lengthSrc) ? length : lengthSrc) > lengthTotal) {
-	    Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
-	}
-	bytesSrc = Tcl_GetByteArrayFromObj(appendObjPtr, NULL);
-	TclAppendBytesToByteArray(objPtr, bytesSrc, lengthSrc);
+
+	/* Grow buffer enough for the append */
+	TclAppendBytesToByteArray(objPtr, NULL, lengthSrc);
+
+	/* Reset objPtr back to the original value */
+	Tcl_SetByteArrayLength(objPtr, length);
+
+	/*
+	 * Now do the append secure that buffer growth cannot cause
+	 * any trouble.
+	 */
+	TclAppendBytesToByteArray(objPtr,
+		Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc);
 	return;
     }
 
-- 
cgit v0.12


From ab8fd1e3f28322c8d57229cd2e171fea351097af Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 19 Jan 2014 18:39:24 +0000
Subject: added compilation for [nextto]

---
 generic/tclAssembly.c   |   1 +
 generic/tclCompCmdsGR.c |  25 +++++++++
 generic/tclCompile.c    |  14 ++++-
 generic/tclCompile.h    |   3 +-
 generic/tclExecute.c    | 132 +++++++++++++++++++++++++++++++++++++++++++-----
 generic/tclInt.h        |   3 ++
 generic/tclOO.c         |   3 +-
 generic/tclOOBasic.c    |  20 ++++++--
 8 files changed, 179 insertions(+), 22 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..7b775a9 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -26,6 +26,7 @@
  *-   jumpTable testing
  *-   syntax (?)
  *-   returnCodeBranch
+ *-   tclooNext, tclooNextClass
  */
 
 #include "tclInt.h"
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index b8a7e0f..b3e273f 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -3075,6 +3075,31 @@ TclCompileObjectNextCmd(
 }
 
 int
+TclCompileObjectNextToCmd(
+    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 = parsePtr->tokenPtr;
+    int i;
+
+    if (parsePtr->numWords < 2 || parsePtr->numWords > 255) {
+	return TCL_ERROR;
+    }
+
+    for (i=0 ; i<parsePtr->numWords ; i++) {
+	CompileWord(envPtr, tokenPtr, interp, i);
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+    TclEmitInstInt1(	INST_TCLOO_NEXT_CLASS, i,	envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileObjectSelfCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ee67e24..bd97e3e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -618,8 +618,18 @@ InstructionDesc const tclInstructionTable[] = {
 	 * Stack:  ... cmdName => ... fullOriginalCmdName */
 
     {"tclooNext",	 2,	INT_MIN,  1,	{OPERAND_UINT1}},
-	/* Push the identity of the current TclOO object (i.e., the name of
-	 * its current public access command) on the stack. */
+	/* Call the next item on the TclOO call chain, passing opnd arguments
+	 * (min 1, max 255, *includes* "next").  The result of the invoked
+	 * method implementation will be pushed on the stack in place of the
+	 * arguments (similar to invokeStk).
+	 * Stack:  ... "next" arg2 arg3 -- argN => ... result */
+    {"tclooNextClass",	 2,	INT_MIN,  1,	{OPERAND_UINT1}},
+	/* Call the following item on the TclOO call chain defined by class
+	 * className, passing opnd arguments (min 2, max 255, *includes*
+	 * "nextto" and the class name). The result of the invoked method
+	 * implementation will be pushed on the stack in place of the
+	 * arguments (similar to invokeStk).
+	 * Stack:  ... "nextto" className arg3 arg4 -- argN => ... result */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6ecadf4..b047855 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -791,9 +791,10 @@ typedef struct ByteCode {
 #define INST_ORIGIN_COMMAND		178
 
 #define INST_TCLOO_NEXT			179
+#define INST_TCLOO_NEXT_CLASS		180
 
 /* The last opcode */
-#define LAST_INST_OPCODE		179
+#define LAST_INST_OPCODE		180
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5b42124..ac0ea12 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4539,6 +4539,7 @@ TEBCresume(
 	Object *oPtr;
 	CallFrame *framePtr;
 	CallContext *contextPtr;
+	int skip, newDepth;
 
     case INST_TCLOO_SELF:
 	framePtr = iPtr->varFramePtr;
@@ -4563,9 +4564,111 @@ TEBCresume(
 	TRACE_WITH_OBJ(("=> "), objResultPtr);
 	NEXT_INST_F(1, 0, 1);
 
+    case INST_TCLOO_NEXT_CLASS:
+	opnd = TclGetUInt1AtPtr(pc+1);
+	framePtr = iPtr->varFramePtr;
+	valuePtr = OBJ_AT_DEPTH(opnd - 2);
+	objv = &OBJ_AT_DEPTH(opnd - 1);
+	skip = 2;
+	TRACE(("%d => ", opnd));
+	if (framePtr == NULL ||
+		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	    TRACE_APPEND(("ERROR: no TclOO call context\n"));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "nextto may only be called from inside a method",
+		    -1));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
+	contextPtr = framePtr->clientData;
+
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
+	if (oPtr == NULL) {
+	    TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
+	    goto gotError;
+	} else {
+	    Class *classPtr = oPtr->classPtr;
+	    struct MInvoke *miPtr;
+	    int i;
+	    const char *methodType;
+
+	    if (classPtr == NULL) {
+		TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"\"%s\" is not a class", TclGetString(valuePtr)));
+		DECACHE_STACK_INFO();
+		Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+		CACHE_STACK_INFO();
+		goto gotError;
+	    }
+
+	    for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+		miPtr = contextPtr->callPtr->chain + i;
+		if (!miPtr->isFilter &&
+			miPtr->mPtr->declaringClassPtr == classPtr) {
+		    newDepth = i;
+#ifdef TCL_COMPILE_DEBUG
+		    if (tclTraceExec >= 2) {
+			if (traceInstructions) {
+			    strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+			} else {
+			    fprintf(stdout, "%d: (%u) invoking ",
+				    iPtr->numLevels,
+				    (unsigned)(pc - codePtr->codeStart));
+			}
+			for (i = 0;  i < opnd;  i++) {
+			    TclPrintObject(stdout, objv[i], 15);
+			    fprintf(stdout, " ");
+			}
+			fprintf(stdout, "\n");
+			fflush(stdout);
+		    }
+#endif /*TCL_COMPILE_DEBUG*/
+		    goto doInvokeNext;
+		}
+	    }
+
+	    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+		methodType = "constructor";
+	    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+		methodType = "destructor";
+	    } else {
+		methodType = "method";
+	    }
+
+	    TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
+		    O2S(valuePtr)));
+	    for (i=contextPtr->index ; i>=0 ; i--) {
+		miPtr = contextPtr->callPtr->chain + i;
+		if (miPtr->isFilter
+			|| miPtr->mPtr->declaringClassPtr != classPtr) {
+		    continue;
+		}
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"%s implementation by \"%s\" not reachable from here",
+			methodType, TclGetString(valuePtr)));
+		DECACHE_STACK_INFO();
+		Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+			NULL);
+		CACHE_STACK_INFO();
+		goto gotError;
+	    }
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "%s has no non-filter implementation by \"%s\"",
+		    methodType, TclGetString(valuePtr)));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
+
     case INST_TCLOO_NEXT:
 	opnd = TclGetUInt1AtPtr(pc+1);
+	objv = &OBJ_AT_DEPTH(opnd - 1);
 	framePtr = iPtr->varFramePtr;
+	skip = 1;
 	TRACE(("%d => ", opnd));
 	if (framePtr == NULL ||
 		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
@@ -4580,7 +4683,8 @@ TEBCresume(
 	}
 	contextPtr = framePtr->clientData;
 
-	if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+	newDepth = contextPtr->index + 1;
+	if (newDepth >= contextPtr->callPtr->numChain) {
 	    /*
 	     * We're at the end of the chain; generate an error message unless
 	     * the interpreter is being torn down, in which case we might be
@@ -4605,33 +4709,31 @@ TEBCresume(
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
 	    CACHE_STACK_INFO();
 	    goto gotError;
-	}
-
 #ifdef TCL_COMPILE_DEBUG
-	if (tclTraceExec >= 2) {
+	} else if (tclTraceExec >= 2) {
 	    int i;
 
 	    if (traceInstructions) {
 		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
-		TRACE(("next_in_chain "));
 	    } else {
-		fprintf(stdout, "%d: (%u) invoking next_in_chain ",
+		fprintf(stdout, "%d: (%u) invoking ",
 			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
 	    }
-	    for (i = 0;  i < objc;  i++) {
+	    for (i = 0;  i < opnd;  i++) {
 		TclPrintObject(stdout, objv[i], 15);
 		fprintf(stdout, " ");
 	    }
 	    fprintf(stdout, "\n");
 	    fflush(stdout);
-	}
 #endif /*TCL_COMPILE_DEBUG*/
+	}
 
+    doInvokeNext:
 	bcFramePtr->data.tebc.pc = (char *) pc;
 	iPtr->cmdFramePtr = bcFramePtr;
 
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
-	    ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
+	    ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv);
 	}
 
 	pcAdjustment = 2;
@@ -4640,6 +4742,7 @@ TEBCresume(
 	iPtr->varFramePtr = framePtr->callerVarPtr;
 	pc += pcAdjustment;
 	TEBC_YIELD();
+
 	oPtr = contextPtr->oPtr;
 	if (oPtr->flags & FILTER_HANDLING) {
 	    TclNRAddCallback(interp, FinalizeOONextFilter,
@@ -4650,20 +4753,21 @@ TEBCresume(
 		    framePtr, contextPtr, INT2PTR(contextPtr->index),
 		    INT2PTR(contextPtr->skip));
 	}
-	if (contextPtr->callPtr->chain[++contextPtr->index].isFilter
+	contextPtr->skip = skip;
+	contextPtr->index = newDepth;
+	if (contextPtr->callPtr->chain[newDepth].isFilter
 		|| contextPtr->callPtr->flags & FILTER_HANDLING) {
 	    oPtr->flags |= FILTER_HANDLING;
 	} else {
 	    oPtr->flags &= ~FILTER_HANDLING;
 	}
-	contextPtr->skip = 1;
+
 	{
 	    register Method *const mPtr =
-		    contextPtr->callPtr->chain[contextPtr->index].mPtr;
+		    contextPtr->callPtr->chain[newDepth].mPtr;
 
 	    return mPtr->typePtr->callProc(mPtr->clientData, interp,
-		    (Tcl_ObjectContext) contextPtr, opnd,
-		    &OBJ_AT_DEPTH(opnd-1));
+		    (Tcl_ObjectContext) contextPtr, opnd, objv);
 	}
 
     case INST_TCLOO_IS_OBJECT:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3aaa30b..7932a58 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3592,6 +3592,9 @@ MODULE_SCOPE int	TclCompileNoOp(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileObjectNextCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileObjectNextToCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileObjectSelfCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 9a0682d..de00733 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -440,8 +440,9 @@ InitFoundation(
     cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
 	    NULL, TclOONextObjCmd, NULL, NULL);
     cmdPtr->compileProc = TclCompileObjectNextCmd;
-    Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
+    cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
 	    NULL, TclOONextToObjCmd, NULL, NULL);
+    cmdPtr->compileProc = TclCompileObjectNextToCmd;
     cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
 	    TclOOSelfObjCmd, NULL, NULL);
     cmdPtr->compileProc = TclCompileObjectSelfCmd;
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 6084cf2..0b0516b 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -821,6 +821,7 @@ TclOONextToObjCmd(
     CallContext *contextPtr;
     int i;
     Tcl_Object object;
+    const char *methodType;
 
     /*
      * Start with sanity checks on the calling context to make sure that we
@@ -886,19 +887,30 @@ TclOONextToObjCmd(
      * is on the chain but unreachable, or not on the chain at all.
      */
 
+    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+	methodType = "constructor";
+    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+	methodType = "destructor";
+    } else {
+	methodType = "method";
+    }
+
     for (i=contextPtr->index ; i>=0 ; i--) {
 	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
 
 	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "method implementation by \"%s\" not reachable from here",
-		    TclGetString(objv[1])));
+		    "%s implementation by \"%s\" not reachable from here",
+		    methodType, TclGetString(objv[1])));
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+		    NULL);
 	    return TCL_ERROR;
 	}
     }
     Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-	    "method has no non-filter implementation by \"%s\"",
-	    TclGetString(objv[1])));
+	    "%s has no non-filter implementation by \"%s\"",
+	    methodType, TclGetString(objv[1])));
+    Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
     return TCL_ERROR;
 }
 
-- 
cgit v0.12


From 61bfac2613d3cc063099ad9e6de3110491b6f5df Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 21 Jan 2014 15:07:59 +0000
Subject: implementation of [yieldto] in bytecode

---
 generic/tclBasic.c      |  2 +-
 generic/tclCompCmdsSZ.c | 45 +++++++++++++++++++++++++++++++
 generic/tclCompile.c    |  7 +++++
 generic/tclCompile.h    |  4 ++-
 generic/tclExecute.c    | 71 ++++++++++++++++++++++++++++++++++++++++++-------
 generic/tclInt.h        |  3 +++
 6 files changed, 121 insertions(+), 11 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 7c02706..e355229 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -259,7 +259,7 @@ static const CmdInfo builtInCmds[] = {
     {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	CMD_IS_SAFE},
     {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	CMD_IS_SAFE},
     {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	CMD_IS_SAFE},
-    {"yieldto",		NULL,			NULL,			TclNRYieldToObjCmd,	CMD_IS_SAFE},
+    {"yieldto",		NULL,			TclCompileYieldToCmd,	TclNRYieldToObjCmd,	CMD_IS_SAFE},
 
     /*
      * Commands in the OS-interface. Note that many of these are unsafe.
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 0f2790f..5c132b4 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -3447,6 +3447,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.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index bd97e3e..f75ac83 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -631,6 +631,13 @@ InstructionDesc const tclInstructionTable[] = {
 	 * arguments (similar to invokeStk).
 	 * Stack:  ... "nextto" className arg3 arg4 -- argN => ... result */
 
+    {"yieldToInvoke",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Makes the current coroutine yield the value at the top of the
+	 * stack, invoking the given command/args with resolution in the given
+	 * namespace (all packed into a list), and places the list of values
+	 * that are the response back on top of the stack when it resumes.
+	 * Stack:  ... [list ns cmd arg1 ... argN] => ... resumeList */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index b047855..7994e2c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -793,8 +793,10 @@ typedef struct ByteCode {
 #define INST_TCLOO_NEXT			179
 #define INST_TCLOO_NEXT_CLASS		180
 
+#define INST_YIELD_TO_INVOKE		181
+
 /* The last opcode */
-#define LAST_INST_OPCODE		180
+#define LAST_INST_OPCODE		181
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ac0ea12..575f227 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2494,9 +2494,12 @@ TEBCresume(
 	TRACE_APPEND(("\n"));
 	goto processExceptionReturn;
 
-    case INST_YIELD: {
-	CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+    {
+	CoroutineData *corPtr;
+	int yieldParameter;
 
+    case INST_YIELD:
+	corPtr = iPtr->execEnvPtr->corPtr;
 	TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
 	if (!corPtr) {
 	    TRACE_APPEND(("ERROR: yield outside coroutine\n"));
@@ -2510,11 +2513,63 @@ TEBCresume(
 	}
 
 #ifdef TCL_COMPILE_DEBUG
-	TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
-	if (traceInstructions) {
-	    fprintf(stdout, "\n");
+	if (tclTraceExec >= 2) {
+	    if (traceInstructions) {
+		TRACE_APPEND(("YIELD...\n"));
+	    } else {
+		fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
+			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+			Tcl_GetString(OBJ_AT_TOS));
+	    }
+	    fflush(stdout);
+	}
+#endif
+	yieldParameter = 0;
+	Tcl_SetObjResult(interp, OBJ_AT_TOS);
+	goto doYield;
+
+    case INST_YIELD_TO_INVOKE:
+	corPtr = iPtr->execEnvPtr->corPtr;
+	valuePtr = OBJ_AT_TOS;
+	if (!corPtr) {
+	    TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
+		    O2S(valuePtr)));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "yieldto can only be called in a coroutine", -1));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+		    NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
+
+#ifdef TCL_COMPILE_DEBUG
+	if (tclTraceExec >= 2) {
+	    if (traceInstructions) {
+		TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
+	    } else {
+		/* FIXME: What is the right thing to trace? */
+		fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
+			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+			Tcl_GetString(valuePtr));
+	    }
+	    fflush(stdout);
 	}
 #endif
+
+	/*
+	 * Install a tailcall record in the caller and continue with the
+	 * yield. The yield is switched into multi-return mode (via the
+	 * 'yieldParameter').
+	 */
+
+	Tcl_IncrRefCount(valuePtr);
+	iPtr->execEnvPtr = corPtr->callerEEPtr;
+	TclSetTailcall(interp, valuePtr);
+	iPtr->execEnvPtr = corPtr->eePtr;
+	yieldParameter = (PTR2INT(NULL)+1);	/*==CORO_ACTIVATE_YIELDM*/
+
+    doYield:
 	/* TIP #280: Record the last piece of info needed by
 	 * 'TclGetSrcInfoForPc', and push the frame.
 	 */
@@ -2529,11 +2584,8 @@ TEBCresume(
 	pc++;
 	cleanup = 1;
 	TEBC_YIELD();
-	
-	Tcl_SetObjResult(interp, OBJ_AT_TOS);
 	TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
-		INT2PTR(0), NULL, NULL);
-
+		INT2PTR(yieldParameter), NULL, NULL);
 	return TCL_OK;
     }
 
@@ -2553,6 +2605,7 @@ TEBCresume(
 	}
 
 #ifdef TCL_COMPILE_DEBUG
+	/* FIXME: What is the right thing to trace? */
 	{
 	    register int i;
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7932a58..6ddb015 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3688,6 +3688,9 @@ MODULE_SCOPE int	TclCompileWhileCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileYieldCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileYieldToCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileBasic0ArgCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From c7ed456462861ff7aaef003c61d8fc526466017d Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 21 Jan 2014 18:16:37 +0000
Subject: Silence compiler warnings.

---
 generic/tclListObj.c | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index d6ffa95..289cf2d 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -1031,8 +1031,8 @@ TclLindexList(
 {
 
     int index;			/* Index into the list. */
-    Tcl_Obj **indices;		/* Array of list indices. */
-    int indexCount;		/* Size of the array of list indices. */
+    Tcl_Obj **indices = NULL;	/* Array of list indices. */
+    int indexCount = -1;	/* Size of the array of list indices. */
     Tcl_Obj *indexListCopy;
 
     /*
@@ -1117,8 +1117,8 @@ TclLindexFlat(
     Tcl_IncrRefCount(listPtr);
 
     for (i=0 ; i<indexCount && listPtr ; i++) {
-	int index, listLen;
-	Tcl_Obj **elemPtrs, *sublistCopy;
+	int index, listLen = 0;
+	Tcl_Obj **elemPtrs = NULL, *sublistCopy;
 
 	/*
 	 * Here we make a private copy of the current sublist, so we avoid any
@@ -1203,8 +1203,8 @@ TclLsetList(
     Tcl_Obj *indexArgPtr,	/* Index or index-list arg to 'lset'. */
     Tcl_Obj *valuePtr)		/* Value arg to 'lset'. */
 {
-    int indexCount;		/* Number of indices in the index list. */
-    Tcl_Obj **indices;		/* Vector of indices in the index list. */
+    int indexCount = 0;		/* Number of indices in the index list. */
+    Tcl_Obj **indices = NULL;	/* Vector of indices in the index list. */
     Tcl_Obj *retValuePtr;	/* Pointer to the list to be returned. */
     int index;			/* Current index in the list - discarded. */
     Tcl_Obj *indexListCopy;
-- 
cgit v0.12


From 78a75740ae5c82cc161e49e5e28a306fa9f2a580 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 22 Jan 2014 09:07:45 +0000
Subject: [a90d9331bc]: must not crash when yieldto called in vanishing
 namespace

---
 generic/tclBasic.c   | 18 ++++------
 generic/tclExecute.c | 11 +++++++
 tests/coroutine.test | 92 +++++++++++++++++++++++++++++++++++++++++++++++++---
 3 files changed, 105 insertions(+), 16 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index e355229..cb9428c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -8431,11 +8431,13 @@ TclNRYieldToObjCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Add the tailcall in the caller env, then just yield.
-     *
-     * This is essentially code from TclNRTailcallObjCmd
-     */
+    if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+        Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"yieldto called in deleted namespace", -1));
+        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+		NULL);
+        return TCL_ERROR;
+    }
 
     /*
      * Add the tailcall in the caller env, then just yield.
@@ -8444,15 +8446,9 @@ TclNRYieldToObjCmd(
      */
 
     listPtr = Tcl_NewListObj(objc, objv);
-
     nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
-    if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
-	    || (nsPtr != ns1Ptr)) {
-	Tcl_Panic("yieldto failed to find the proper namespace");
-    }
     TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
 
-
     /*
      * Add the callback in the caller's env, then instruct TEBC to yield.
      */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 575f227..6749120 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2542,6 +2542,17 @@ TEBCresume(
 	    CACHE_STACK_INFO();
 	    goto gotError;
 	}
+	if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+	    TRACE(("[%.30s] => ERROR: yield in deleted\n",
+		    O2S(valuePtr)));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "yieldto called in deleted namespace", -1));
+	    DECACHE_STACK_INFO();
+	    Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+		    NULL);
+	    CACHE_STACK_INFO();
+	    goto gotError;
+	}
 
 #ifdef TCL_COMPILE_DEBUG
 	if (tclTraceExec >= 2) {
diff --git a/tests/coroutine.test b/tests/coroutine.test
index a360fd5..05b58c9 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -1,4 +1,4 @@
-# Commands covered:  coroutine, yield, [info coroutine]
+# Commands covered:  coroutine, yield, yieldto, [info coroutine]
 #
 # This file contains a collection of tests for experimental commands that are
 # found in ::tcl::unsupported. The tests will migrate to normal test files
@@ -612,7 +612,6 @@ test coroutine-7.3 {yielding between coroutines} -body {
 } -cleanup {
     catch {rename juggler ""}
 } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
-
 test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
     proc foo {a b} {catch yield; return 1}
 } -cleanup {
@@ -620,7 +619,6 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
 } -body {
     coroutine demo lsort -command foo {a b}
 } -result {b a}
-
 test coroutine-7.5 {return codes} {
     set result {}
     foreach code {0 1 2 3 4 5} {
@@ -628,14 +626,12 @@ test coroutine-7.5 {return codes} {
     }
     set result
 } {0 1 2 3 4 5}
-
 test coroutine-7.6 {Early yield crashes} {
     proc foo args {}
     trace add execution foo enter {catch yield}
     coroutine demo foo
     rename foo {}
 } {}
-
 test coroutine-7.7 {Bug 2486550} -setup {
     interp hide {} yield
 } -body {
@@ -644,6 +640,92 @@ test coroutine-7.7 {Bug 2486550} -setup {
     demo
     interp expose {} yield
 } -result ok
+test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	yieldto ::return -level 0 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    namespace delete cotest
+    namespace eval cotest {}
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	set y ::yieldto
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	$y ::return -level 0 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    namespace delete cotest
+    namespace eval cotest {}
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
+    namespace eval cotest {}
+    set ::result ""
+} -body {
+    proc cotest::body {} {
+	set y ::yieldto
+	lappend ::result a
+	yield OUT
+	lappend ::result b
+	$y ::return -level 0 -cotest [namespace delete ::cotest] 123
+	lappend ::result c
+	return
+    }
+    lappend ::result [coroutine cotest cotest::body]
+    lappend ::result [cotest]
+    cotest
+    return $result
+} -returnCodes error -cleanup {
+    catch {namespace delete ::cotest}
+    catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
 
 
 # cleanup
-- 
cgit v0.12


From 6e072443704a589149fea001df51f9870b78c323 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 22 Jan 2014 09:14:57 +0000
Subject: minor tidying up

---
 generic/tclBasic.c | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index cb9428c..46b532b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -8416,8 +8416,7 @@ TclNRYieldToObjCmd(
 {
     CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
     Tcl_Obj *listPtr, *nsObjPtr;
-    Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
-    Tcl_Namespace *ns1Ptr;
+    Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
@@ -8431,7 +8430,7 @@ TclNRYieldToObjCmd(
 	return TCL_ERROR;
     }
 
-    if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+    if (((Namespace *) nsPtr)->flags & NS_DYING) {
         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"yieldto called in deleted namespace", -1));
         Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
-- 
cgit v0.12


From 75c91591589708f766539aef319bfb7d80d7f0a8 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 22 Jan 2014 13:48:16 +0000
Subject: remove unused variable

---
 generic/tclBasic.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index cb9428c..1aea752 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -8417,7 +8417,6 @@ TclNRYieldToObjCmd(
     CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
     Tcl_Obj *listPtr, *nsObjPtr;
     Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
-    Tcl_Namespace *ns1Ptr;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
-- 
cgit v0.12


From 8af83eeffaedc4ee57ade8026a6f7166b86306d6 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 24 Jan 2014 17:38:59 +0000
Subject: Eliminate the copy to a staging buffer when that serves no functional
 purpose.

---
 generic/tclIO.c | 22 ++++++++++++----------
 1 file changed, 12 insertions(+), 10 deletions(-)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index f1d8909..13494ca 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -3787,16 +3787,17 @@ WriteChars(
     consumedSomething = 1;
     while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
 	consumedSomething = 0;
-	stage = statePtr->outputStage;
-	stageMax = statePtr->bufSize;
-	stageLen = stageMax;
-
-	toWrite = stageLen;
-	if (toWrite > srcLen) {
-	    toWrite = srcLen;
-	}
 
 	if (translate) {
+	    stage = statePtr->outputStage;
+	    stageMax = statePtr->bufSize;
+	    stageLen = stageMax;
+
+	    toWrite = stageLen;
+	    if (toWrite > srcLen) {
+		toWrite = srcLen;
+	    }
+
 	    if (savedLF) {
 		/*
 		 * A '\n' was left over from last call to TranslateOutputEOL()
@@ -3822,8 +3823,9 @@ WriteChars(
 		stageLen = stageMax;
 	    }
 	} else {
-	    memcpy(stage, src, toWrite);
-	    stageLen = toWrite;
+	    stage = (char *) src;
+	    stageLen = srcLen;
+	    toWrite = stageLen;
 	}
 	src += toWrite;
 	srcLen -= toWrite;
-- 
cgit v0.12


From 9d0cf098518e48651256d556d750716978ea57df Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Sat, 25 Jan 2014 21:41:12 +0000
Subject: sync tcl.m4 with Tk version

---
 unix/configure | 2 ++
 unix/tcl.m4    | 2 ++
 2 files changed, 4 insertions(+)

diff --git a/unix/configure b/unix/configure
index 7f8922b..6800fe2 100755
--- a/unix/configure
+++ b/unix/configure
@@ -6939,6 +6939,7 @@ fi
 	    TCL_NEEDS_EXP_FILE=1
 	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a'
 	    TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a'
+	    TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a'
 	    echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5
 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6
 if test "${ac_cv_cygwin+set}" = set; then
@@ -7652,6 +7653,7 @@ fi
 	    SHLIB_CFLAGS="-fPIC"
 	    SHLIB_LD="${CC} -shared"
 	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@"
+	    TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$@"
 	    SHLIB_SUFFIX=".so"
 	    DL_OBJS="tclLoadDl.o"
 	    DL_LIBS=""
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index e9795b8..c57111b 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1247,6 +1247,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	    TCL_NEEDS_EXP_FILE=1
 	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a'
 	    TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a'
+	    TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a'
 	    AC_CACHE_CHECK(for Cygwin version of gcc,
 		ac_cv_cygwin,
 		AC_TRY_COMPILE([
@@ -1563,6 +1564,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	    SHLIB_CFLAGS="-fPIC"
 	    SHLIB_LD="${CC} -shared"
 	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]"
+	    TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]"
 	    SHLIB_SUFFIX=".so"
 	    DL_OBJS="tclLoadDl.o"
 	    DL_LIBS=""
-- 
cgit v0.12


From b555fa4d44d0b13c0c4e61643e22f6c3479baf4e Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 28 Jan 2014 11:04:57 +0000
Subject: WIP

---
 generic/tclIO.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 69 insertions(+)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index 13494ca..fdb0ddd 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -3779,6 +3779,74 @@ WriteChars(
     translate = (statePtr->flags & CHANNEL_LINEBUFFERED)
 	|| (statePtr->outputTranslation != TCL_TRANSLATE_LF);
 
+#if 0
+    consumedSomething = 1;
+    while (consumedSomething && (srcLen + saved + endEncoding > 0)) {
+	void *lastNewLine;
+	int srcLimit;
+	
+	/* Get space to write into */
+	bufPtr = statePtr->curOutPtr;
+	if (bufPtr == NULL) {
+	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
+	    statePtr->curOutPtr = bufPtr;
+	    if (saved) {
+		/*
+		 * Here's some translated bytes left over from the last buffer
+		 * that we need to stick at the beginning of this buffer.
+		 */
+
+		memcpy(InsertPoint(bufPtr), safe, (size_t) saved);
+		bufPtr->nextAdded += saved;
+		saved = 0;
+	    }
+	}
+	dst = InsertPoint(bufPtr);
+	dstLen = SpaceLeft(bufPtr);
+
+	/*
+	 * We have dstLen bytes to write to.  The most source bytes
+	 * that could possibly fill that is TCL_UTF_MAX * dstLen.
+	 */
+
+	srcLimit = TCL_UTF_MAX * dstLen;
+	if (srcLen < srcLimit) {
+	    srcLimit = srcLen;
+	}
+	lastNewLine = memchr(src, '\n', srcLimit);
+
+	if (lastNewLine) {
+	    srcLimit = lastNewLine - src;
+	}
+	
+	result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit,
+		statePtr->outputEncodingFlags,
+		&statePtr->outputEncodingState, dst,
+		dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
+
+	statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
+	
+	if ((result != 0) && (srcRead + dstWrote == 0)) {
+	    fprintf(stdout, "WDTH?\n"); fflush(stdout);
+	}
+	bufPtr->nextAdded += dstWrote;
+	if (IsBufferOverflowing(bufPtr)) {
+	    /*
+	     * When translating from UTF-8 to external encoding, we
+	     * allowed the translation to produce a character that crossed
+	     * the end of the output buffer, so that we would get a
+	     * completely full buffer before flushing it. The extra bytes
+	     * will be moved to the beginning of the next buffer.
+	     */
+
+	    saved = -SpaceLeft(bufPtr);
+	    memcpy(safe, dst + dstLen, (size_t) saved);
+	    bufPtr->nextAdded = bufPtr->bufLength;
+	}
+	
+    
+    }
+#else
     /*
      * Loop over all UTF-8 characters in src, storing them in staging buffer
      * with proper EOL translation.
@@ -3933,6 +4001,7 @@ WriteChars(
 	    }
 	}
     }
+#endif
 
     /*
      * If nothing was written and it happened because there was no progress in
-- 
cgit v0.12


From 15c8e0fd00cb9a49203a6de6cd05ec758daf519e Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 28 Jan 2014 18:51:59 +0000
Subject: Working code with no staging buffer use.

---
 generic/tclIO.c | 128 ++++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 97 insertions(+), 31 deletions(-)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index fdb0ddd..7203739 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -3756,18 +3756,21 @@ WriteChars(
     char *dst, *stage;
     int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
     int stageLen, toWrite, stageRead, endEncoding, result;
-    int consumedSomething, translate;
+    int consumedSomething, translate, flushed, needNlFlush;
     Tcl_Encoding encoding;
     char safe[BUFFER_PADDING];
+    char *nextNewLine = NULL;
 
     if (srcLen) {
         WillWrite(chanPtr);
     }
 
+    flushed = 0;
     total = 0;
     sawLF = 0;
     savedLF = 0;
     saved = 0;
+    needNlFlush = 0;
     encoding = statePtr->encoding;
 
     /*
@@ -3779,46 +3782,39 @@ WriteChars(
     translate = (statePtr->flags & CHANNEL_LINEBUFFERED)
 	|| (statePtr->outputTranslation != TCL_TRANSLATE_LF);
 
-#if 0
+#if 1
+    if (translate) {
+	nextNewLine = memchr(src, '\n', srcLen);
+    }
     consumedSomething = 1;
     while (consumedSomething && (srcLen + saved + endEncoding > 0)) {
-	void *lastNewLine;
-	int srcLimit;
+	int srcRead;
+	int srcLimit = srcLen;
+
+	consumedSomething = 0;
+	if (nextNewLine) {
+	    srcLimit = nextNewLine - src;
+	}
 	
 	/* Get space to write into */
 	bufPtr = statePtr->curOutPtr;
 	if (bufPtr == NULL) {
 	    bufPtr = AllocChannelBuffer(statePtr->bufSize);
 	    statePtr->curOutPtr = bufPtr;
-	    if (saved) {
-		/*
-		 * Here's some translated bytes left over from the last buffer
-		 * that we need to stick at the beginning of this buffer.
-		 */
+	}
+	if (saved) {
+	    /*
+	     * Here's some translated bytes left over from the last buffer
+	     * that we need to stick at the beginning of this buffer.
+	     */
 
-		memcpy(InsertPoint(bufPtr), safe, (size_t) saved);
-		bufPtr->nextAdded += saved;
-		saved = 0;
-	    }
+	    memcpy(InsertPoint(bufPtr), safe, (size_t) saved);
+	    bufPtr->nextAdded += saved;
+	    saved = 0;
 	}
 	dst = InsertPoint(bufPtr);
 	dstLen = SpaceLeft(bufPtr);
 
-	/*
-	 * We have dstLen bytes to write to.  The most source bytes
-	 * that could possibly fill that is TCL_UTF_MAX * dstLen.
-	 */
-
-	srcLimit = TCL_UTF_MAX * dstLen;
-	if (srcLen < srcLimit) {
-	    srcLimit = srcLen;
-	}
-	lastNewLine = memchr(src, '\n', srcLimit);
-
-	if (lastNewLine) {
-	    srcLimit = lastNewLine - src;
-	}
-	
 	result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit,
 		statePtr->outputEncodingFlags,
 		&statePtr->outputEncodingState, dst,
@@ -3827,9 +3823,59 @@ WriteChars(
 	statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
 	
 	if ((result != 0) && (srcRead + dstWrote == 0)) {
-	    fprintf(stdout, "WDTH?\n"); fflush(stdout);
+	    /* We're reading from invalid/incomplete UTF-8 */
+	    break;
 	}
+
+	consumedSomething = 1;
 	bufPtr->nextAdded += dstWrote;
+	src += srcRead;
+	srcLen -= srcRead;
+	total += dstWrote;
+	dst += dstWrote;
+	dstLen -= dstWrote;
+
+	if (src == nextNewLine && dstLen > 0) {
+	    static char crln[3] = "\r\n";
+	    char *nl = NULL;
+	    int nlLen = 0;
+
+	    switch (statePtr->outputTranslation) {
+	    case TCL_TRANSLATE_LF:
+		nl = crln + 1;
+		nlLen = 1;
+		break;
+	    case TCL_TRANSLATE_CR:
+		nl = crln;
+		nlLen = 1;
+		break;
+	    case TCL_TRANSLATE_CRLF:
+		nl = crln;
+		nlLen = 2;
+		break;
+	    default:
+		Tcl_Panic("unknown output translation requested");
+		break;
+	    }
+	
+	    result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen,
+		statePtr->outputEncodingFlags,
+		&statePtr->outputEncodingState, dst,
+		dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
+
+	    if (srcRead != nlLen) {
+		Tcl_Panic("Can This Happen?");
+	    }
+
+	    bufPtr->nextAdded += dstWrote;
+	    src++;
+	    srcLen--;
+	    total += dstWrote;
+	    dst += dstWrote;
+	    dstLen -= dstWrote;
+	    nextNewLine = memchr(src, '\n', srcLen);
+	    needNlFlush = 1;
+	}
 	if (IsBufferOverflowing(bufPtr)) {
 	    /*
 	     * When translating from UTF-8 to external encoding, we
@@ -3843,8 +3889,28 @@ WriteChars(
 	    memcpy(safe, dst + dstLen, (size_t) saved);
 	    bufPtr->nextAdded = bufPtr->bufLength;
 	}
-	
-    
+
+	if ((srcLen + saved == 0) && (result == 0)) {
+	    endEncoding = 0;
+	}
+
+	/* FLUSH ! */
+	if (IsBufferFull(bufPtr)) {
+	    if (FlushChannel(NULL, chanPtr, 0) != 0) {
+		return -1;
+	    }
+	    flushed += statePtr->bufSize;
+	    if (saved == 0 || src[-1] != '\n') {
+		needNlFlush = 0;
+	    }
+	}
+    }
+    if ((flushed < total) && (statePtr->flags & CHANNEL_UNBUFFERED ||
+	    (needNlFlush && statePtr->flags & CHANNEL_LINEBUFFERED))) {
+	SetFlag(statePtr, BUFFER_READY);
+	if (FlushChannel(NULL, chanPtr, 0) != 0) {
+	    return -1;
+	}
     }
 #else
     /*
-- 
cgit v0.12


From 589975911949b9661152610ca04cf5e8e233a109 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 28 Jan 2014 20:19:39 +0000
Subject: tidy things up

---
 generic/tclIO.c | 211 +++++---------------------------------------------------
 1 file changed, 17 insertions(+), 194 deletions(-)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index 7203739..c7c11e7 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -3752,46 +3752,30 @@ WriteChars(
 {
     ChannelState *statePtr = chanPtr->state;
 				/* State info for channel */
-    ChannelBuffer *bufPtr;
-    char *dst, *stage;
-    int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
-    int stageLen, toWrite, stageRead, endEncoding, result;
-    int consumedSomething, translate, flushed, needNlFlush;
-    Tcl_Encoding encoding;
-    char safe[BUFFER_PADDING];
     char *nextNewLine = NULL;
+    int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0;
+    Tcl_Encoding encoding = statePtr->encoding;
 
     if (srcLen) {
         WillWrite(chanPtr);
     }
 
-    flushed = 0;
-    total = 0;
-    sawLF = 0;
-    savedLF = 0;
-    saved = 0;
-    needNlFlush = 0;
-    encoding = statePtr->encoding;
-
     /*
      * Write the terminated escape sequence even if srcLen is 0.
      */
 
     endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
 
-    translate = (statePtr->flags & CHANNEL_LINEBUFFERED)
-	|| (statePtr->outputTranslation != TCL_TRANSLATE_LF);
-
-#if 1
-    if (translate) {
+    if ((statePtr->flags & CHANNEL_LINEBUFFERED)
+	    || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
 	nextNewLine = memchr(src, '\n', srcLen);
     }
-    consumedSomething = 1;
-    while (consumedSomething && (srcLen + saved + endEncoding > 0)) {
-	int srcRead;
-	int srcLimit = srcLen;
 
-	consumedSomething = 0;
+    while (srcLen + saved + endEncoding > 0) {
+	ChannelBuffer *bufPtr;
+	char *dst, safe[BUFFER_PADDING];
+	int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
+
 	if (nextNewLine) {
 	    srcLimit = nextNewLine - src;
 	}
@@ -3820,14 +3804,18 @@ WriteChars(
 		&statePtr->outputEncodingState, dst,
 		dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
 
+	/* See chan-io-1.[89]. Tcl Bug 506297. */
 	statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
 	
-	if ((result != 0) && (srcRead + dstWrote == 0)) {
+	if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
 	    /* We're reading from invalid/incomplete UTF-8 */
+	    if (total == 0) {
+		Tcl_SetErrno(EINVAL);
+		return -1;
+	    }
 	    break;
 	}
 
-	consumedSomething = 1;
 	bufPtr->nextAdded += dstWrote;
 	src += srcRead;
 	srcLen -= srcRead;
@@ -3876,6 +3864,7 @@ WriteChars(
 	    nextNewLine = memchr(src, '\n', srcLen);
 	    needNlFlush = 1;
 	}
+
 	if (IsBufferOverflowing(bufPtr)) {
 	    /*
 	     * When translating from UTF-8 to external encoding, we
@@ -3890,11 +3879,10 @@ WriteChars(
 	    bufPtr->nextAdded = bufPtr->bufLength;
 	}
 
-	if ((srcLen + saved == 0) && (result == 0)) {
+	if ((srcLen + saved == 0) && (result == TCL_OK)) {
 	    endEncoding = 0;
 	}
 
-	/* FLUSH ! */
 	if (IsBufferFull(bufPtr)) {
 	    if (FlushChannel(NULL, chanPtr, 0) != 0) {
 		return -1;
@@ -3912,172 +3900,7 @@ WriteChars(
 	    return -1;
 	}
     }
-#else
-    /*
-     * Loop over all UTF-8 characters in src, storing them in staging buffer
-     * with proper EOL translation.
-     */
-
-    consumedSomething = 1;
-    while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
-	consumedSomething = 0;
-
-	if (translate) {
-	    stage = statePtr->outputStage;
-	    stageMax = statePtr->bufSize;
-	    stageLen = stageMax;
-
-	    toWrite = stageLen;
-	    if (toWrite > srcLen) {
-		toWrite = srcLen;
-	    }
-
-	    if (savedLF) {
-		/*
-		 * A '\n' was left over from last call to TranslateOutputEOL()
-		 * and we need to store it in the staging buffer. If the channel
-		 * is line-based, we will need to flush the output buffer (after
-		 * translating the staging buffer).
-		 */
-
-		*stage++ = '\n';
-		stageLen--;
-		sawLF++;
-	    }
-	    if (TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite)) {
-		sawLF++;
-	    }
-
-	    stage -= savedLF;
-	    stageLen += savedLF;
-	    savedLF = 0;
-
-	    if (stageLen > stageMax) {
-		savedLF = 1;
-		stageLen = stageMax;
-	    }
-	} else {
-	    stage = (char *) src;
-	    stageLen = srcLen;
-	    toWrite = stageLen;
-	}
-	src += toWrite;
-	srcLen -= toWrite;
-
-	/*
-	 * Loop over all UTF-8 characters in staging buffer, converting them
-	 * to external encoding, storing them in output buffer.
-	 */
-
-	while (stageLen + saved + endEncoding > 0) {
-	    bufPtr = statePtr->curOutPtr;
-	    if (bufPtr == NULL) {
-		bufPtr = AllocChannelBuffer(statePtr->bufSize);
-		statePtr->curOutPtr = bufPtr;
-	    }
-	    dst = InsertPoint(bufPtr);
-	    dstLen = SpaceLeft(bufPtr);
 
-	    if (saved != 0) {
-		/*
-		 * Here's some translated bytes left over from the last buffer
-		 * that we need to stick at the beginning of this buffer.
-		 */
-
-		memcpy(dst, safe, (size_t) saved);
-		bufPtr->nextAdded += saved;
-		dst += saved;
-		dstLen -= saved;
-		saved = 0;
-	    }
-
-	    result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen,
-		    statePtr->outputEncodingFlags,
-		    &statePtr->outputEncodingState, dst,
-		    dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL);
-
-	    /*
-	     * Fix for SF #506297, reported by Martin Forssen
-	     * <ruric@users.sourceforge.net>.
-	     *
-	     * The encoding chosen in the script exposing the bug writes out
-	     * three intro characters when TCL_ENCODING_START is set, but does
-	     * not consume any input as TCL_ENCODING_END is cleared. As some
-	     * output was generated the enclosing loop calls UtfToExternal
-	     * again, again with START set. Three more characters in the out
-	     * and still no use of input ... To break this infinite loop we
-	     * remove TCL_ENCODING_START from the set of flags after the first
-	     * call (no condition is required, the later calls remove an unset
-	     * flag, which is a no-op). This causes the subsequent calls to
-	     * UtfToExternal to consume and convert the actual input.
-	     */
-
-	    statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
-
-	    /*
-	     * The following code must be executed only when result is not 0.
-	     */
-
-	    if ((result != 0) && (stageRead + dstWrote == 0)) {
-		/*
-		 * We have an incomplete UTF-8 character at the end of the
-		 * staging buffer. It will get moved to the beginning of the
-		 * staging buffer followed by more bytes from src.
-		 */
-
-		src -= stageLen;
-		srcLen += stageLen;
-		stageLen = 0;
-		savedLF = 0;
-		break;
-	    }
-	    bufPtr->nextAdded += dstWrote;
-	    if (IsBufferOverflowing(bufPtr)) {
-		/*
-		 * When translating from UTF-8 to external encoding, we
-		 * allowed the translation to produce a character that crossed
-		 * the end of the output buffer, so that we would get a
-		 * completely full buffer before flushing it. The extra bytes
-		 * will be moved to the beginning of the next buffer.
-		 */
-
-		saved = -SpaceLeft(bufPtr);
-		memcpy(safe, dst + dstLen, (size_t) saved);
-		bufPtr->nextAdded = bufPtr->bufLength;
-	    }
-	    if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
-		return -1;
-	    }
-
-	    total += dstWrote;
-	    stage += stageRead;
-	    stageLen -= stageRead;
-	    sawLF = 0;
-
-	    consumedSomething = 1;
-
-	    /*
-	     * If all translated characters are written to the buffer,
-	     * endEncoding is set to 0 because the escape sequence may be
-	     * output.
-	     */
-
-	    if ((stageLen + saved == 0) && (result == 0)) {
-		endEncoding = 0;
-	    }
-	}
-    }
-#endif
-
-    /*
-     * If nothing was written and it happened because there was no progress in
-     * the UTF conversion, we throw an error.
-     */
-
-    if (!consumedSomething && (total == 0)) {
-	Tcl_SetErrno(EINVAL);
-	return -1;
-    }
     return total;
 }
 
-- 
cgit v0.12


From 9df81fccd3a1cfd90a732c1116cb3bf467bbe802 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 28 Jan 2014 20:23:26 +0000
Subject: The outputStage field is now unused, so never allocate it.

---
 generic/tclIO.c | 29 -----------------------------
 1 file changed, 29 deletions(-)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index c7c11e7..4ae9ec0 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -1489,12 +1489,7 @@ Tcl_CreateChannel(
     statePtr->timer		= NULL;
     statePtr->csPtrR		= NULL;
     statePtr->csPtrW		= NULL;
-
     statePtr->outputStage	= NULL;
-    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
-	statePtr->outputStage = (char *)
-		ckalloc((unsigned) (statePtr->bufSize + 2));
-    }
 
     /*
      * As we are creating the channel, it is obviously the top for now.
@@ -2757,10 +2752,6 @@ CloseChannel(
 	}
 
 	Tcl_FreeEncoding(statePtr->encoding);
-	if (statePtr->outputStage != NULL) {
-	    ckfree((char *) statePtr->outputStage);
-	    statePtr->outputStage = NULL;
-	}
     }
 
     /*
@@ -7151,15 +7142,6 @@ Tcl_SetChannelBufferSize(
 
     statePtr = ((Channel *) chan)->state;
     statePtr->bufSize = sz;
-
-    if (statePtr->outputStage != NULL) {
-	ckfree((char *) statePtr->outputStage);
-	statePtr->outputStage = NULL;
-    }
-    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
-	statePtr->outputStage = (char *)
-		ckalloc((unsigned) (statePtr->bufSize + 2));
-    }
 }
 
 /*
@@ -7800,17 +7782,6 @@ Tcl_SetChannelOption(
 	statePtr->inQueueTail = NULL;
     }
 
-    /*
-     * If encoding or bufsize changes, need to update output staging buffer.
-     */
-
-    if (statePtr->outputStage != NULL) {
-	ckfree(statePtr->outputStage);
-	statePtr->outputStage = NULL;
-    }
-    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
-	statePtr->outputStage = ckalloc((unsigned) (statePtr->bufSize + 2));
-    }
     return TCL_OK;
 }
 
-- 
cgit v0.12


From 60e360f12b1c25a8e89f5893a564ca17d3b99217 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 29 Jan 2014 13:59:32 +0000
Subject: Compile [string is] with character classes in a non-awful way. Needs
 more work to make resulting bytecode disassemble nicely.

---
 generic/tclCompCmdsSZ.c | 99 ++++++++++++++++++++++++++++++++++++++++++++-----
 generic/tclCompile.c    |  5 +++
 generic/tclCompile.h    | 37 +++++++++++++++++-
 generic/tclExecute.c    | 19 ++++++++++
 4 files changed, 150 insertions(+), 10 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 1a69a89..639b4a5 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -452,6 +452,7 @@ TclCompileStringIsCmd(
 	STR_IS_XDIGIT
     };
     int t, range, allowEmpty = 0, end;
+    InstStringClassType strClassType;
     Tcl_Obj *isClass;
 
     if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
@@ -486,7 +487,7 @@ TclCompileStringIsCmd(
 
     tokenPtr = TokenAfter(tokenPtr);
     if (parsePtr->numWords == 3) {
-	allowEmpty = (t != STR_IS_LIST);
+	allowEmpty = 1;
     } else {
 	if (!GotLiteral(tokenPtr, "-strict")) {
 	    return TCL_ERROR;
@@ -496,30 +497,77 @@ TclCompileStringIsCmd(
 #undef GotLiteral
 
     /*
-     * Some types are not currently handled. Character classes are a prime
-     * example of this.
+     * 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:
-	return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+	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:
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	OP(		TRY_CVT_TO_BOOLEAN);
 	switch (t) {
 	    int over, over2;
@@ -569,7 +617,6 @@ TclCompileStringIsCmd(
     case STR_IS_DOUBLE: {
 	int satisfied, isEmpty;
 
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	if (allowEmpty) {
 	    OP(		DUP);
 	    PUSH(	"");
@@ -598,7 +645,6 @@ TclCompileStringIsCmd(
     case STR_IS_INT:
     case STR_IS_WIDE:
     case STR_IS_ENTIER:
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	if (allowEmpty) {
 	    int testNumType;
 
@@ -638,7 +684,6 @@ TclCompileStringIsCmd(
 	return TCL_OK;
 
     case STR_IS_LIST:
-	CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
 	range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
 	OP4(		BEGIN_CATCH4, range);
 	ExceptionRangeStarts(envPtr, range);
@@ -653,7 +698,8 @@ TclCompileStringIsCmd(
 	OP(		LNOT);
 	return TCL_OK;
     }
-    return TCL_ERROR;
+
+    return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 }
 
 int
@@ -1171,6 +1217,41 @@ TclCompileStringToTitleCmd(
 }
 
 /*
+ * 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}
+};
+
+/*
  *----------------------------------------------------------------------
  *
  * TclCompileSubstCmd --
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index fdc3e26..08a7a4c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -644,6 +644,11 @@ InstructionDesc const tclInstructionTable[] = {
     {"tryCvtToBoolean",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Try converting stktop to boolean if possible. No errors.
 	 * Stack:  ... value => ... value isStrictBool */
+    {"strclass",	 2,	0,	  1,	{OPERAND_UINT1}},
+	/* See if all the characters of the given string are a member of the
+	 * specified (by opnd) character class. Note that an empty string will
+	 * satisfy the class check (standard definition of "all").
+	 * Stack:  ... stringValue => ... boolean */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index d6d515d..502a2e6 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -797,9 +797,10 @@ typedef struct ByteCode {
 
 #define INST_NUM_TYPE			182
 #define INST_TRY_CVT_TO_BOOLEAN		183
+#define INST_STR_CLASS			184
 
 /* The last opcode */
-#define LAST_INST_OPCODE		183
+#define LAST_INST_OPCODE		184
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
@@ -844,6 +845,40 @@ typedef struct InstructionDesc {
 MODULE_SCOPE InstructionDesc const tclInstructionTable[];
 
 /*
+ * Constants used by INST_STRING_CLASS to indicate character classes. These
+ * correspond closely by name with what [string is] can support, but there is
+ * no requirement to keep the values the same.
+ */
+
+typedef enum InstStringClassType {
+    STR_CLASS_ALNUM,		/* Unicode alphabet or digit characters. */
+    STR_CLASS_ALPHA,		/* Unicode alphabet characters. */
+    STR_CLASS_ASCII,		/* Characters in range U+000000..U+00007F. */
+    STR_CLASS_CONTROL,		/* Unicode control characters. */
+    STR_CLASS_DIGIT,		/* Unicode digit characters. */
+    STR_CLASS_GRAPH,		/* Unicode printing characters, excluding
+				 * space. */
+    STR_CLASS_LOWER,		/* Unicode lower-case alphabet characters. */
+    STR_CLASS_PRINT,		/* Unicode printing characters, including
+				 * spaces. */
+    STR_CLASS_PUNCT,		/* Unicode punctuation characters. */
+    STR_CLASS_SPACE,		/* Unicode space characters. */
+    STR_CLASS_UPPER,		/* Unicode upper-case alphabet characters. */
+    STR_CLASS_WORD,		/* Unicode word (alphabetic, digit, connector
+				 * punctuation) characters. */
+    STR_CLASS_XDIGIT		/* Characters that can be used as digits in
+				 * hexadecimal numbers ([0-9A-Fa-f]). */
+} InstStringClassType;
+
+typedef struct StringClassDesc {
+    const char *name;		/* Name of the class. */
+    int (*comparator)(int);	/* Function to test if a single unicode
+				 * character is a member of the class. */
+} StringClassDesc;
+
+MODULE_SCOPE StringClassDesc const tclStringClassTable[];
+
+/*
  * Compilation of some Tcl constructs such as if commands and the logical or
  * (||) and logical and (&&) operators in expressions requires the generation
  * of forward jumps. Since the PC target of these jumps isn't known when the
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 916de17..58d85e1 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5810,6 +5810,25 @@ TEBCresume(
 
 	TclNewIntObj(objResultPtr, match);
 	NEXT_INST_F(1, 2, 1);
+
+    case INST_STR_CLASS:
+	opnd = TclGetInt1AtPtr(pc+1);
+	valuePtr = OBJ_AT_TOS;
+	TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
+		O2S(valuePtr)));
+	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+	match = 1;
+	if (length > 0) {
+	    end = ustring1 + length;
+	    for (p=ustring1 ; p<end ; p++) {
+		if (!tclStringClassTable[opnd].comparator(*p)) {
+		    match = 0;
+		    break;
+		}
+	    }
+	}
+	TRACE_APPEND(("%d\n", match));
+	JUMP_PEEPHOLE_F(match, 2, 1);
     }
 
     case INST_STR_MATCH:
-- 
cgit v0.12


From 696b86227c0d696dd8624610b194a8bc67e6d112 Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Wed, 29 Jan 2014 23:18:58 +0000
Subject: Squashed C99 syntax breaking the native AIX cc.

---
 generic/tclAssembly.c | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 7b775a9..55a0c3f 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -50,7 +50,7 @@ typedef enum BasicBlockCatchState {
     BBCS_UNKNOWN = 0,		/* Catch context has not yet been identified */
     BBCS_NONE,			/* Block is outside of any catch */
     BBCS_INCATCH,		/* Block is within a catch context */
-    BBCS_CAUGHT,		/* Block is within a catch context and
+    BBCS_CAUGHT 		/* Block is within a catch context and
 				 * may be executed after an exception fires */
 } BasicBlockCatchState;
 
@@ -121,7 +121,7 @@ enum BasicBlockFlags {
 				 * marking it as the start of a 'catch'
 				 * sequence. The 'jumpTarget' is the exception
 				 * exit from the catch block. */
-    BB_ENDCATCH = (1 << 5),	/* Block ends with an 'endCatch' instruction,
+    BB_ENDCATCH = (1 << 5)	/* Block ends with an 'endCatch' instruction,
 				 * unwinding the catch from the exception
 				 * stack. */
 };
@@ -184,7 +184,7 @@ typedef enum TalInstType {
 				 * produces N */
     ASSEM_SINT1,		/* One 1-byte signed-integer operand
 				 * (INCR_STK_IMM) */
-    ASSEM_SINT4_LVT4,		/* Signed 4-byte integer operand followed by
+    ASSEM_SINT4_LVT4		/* Signed 4-byte integer operand followed by
 				 * LVT entry.  Fixed arity */
 } TalInstType;
 
-- 
cgit v0.12


From 9ac255b85b57fd192a8255ed8d8ca73bf5306748 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 30 Jan 2014 14:44:56 +0000
Subject: Fix [22c10c8e79]: core-8-5: msvc6 build: "Side by Side" error

---
 win/makefile.vc | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/win/makefile.vc b/win/makefile.vc
index 4466439..152cc66 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -902,7 +902,7 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c
 $(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in
 	@nmakehlp -s << $** >$@
 @MACHINE@	  $(MACHINE:IX86=X86)
-@TCL_WIN_VERSION@  $(TCL_DOTVERSION).0.0
+@TCL_WIN_VERSION@  $(DOTVERSION).0.0
 <<
 
 #---------------------------------------------------------------------
-- 
cgit v0.12


From 81e405a16c6eff768e23d1c43c292e4875b86a16 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 31 Jan 2014 09:13:13 +0000
Subject: Fix [4b3b7a3082]: tcl8.5.15/generic/tclExecute.c:7713: array index
 before sanity check ?

---
 generic/tclExecute.c | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e657828..2e396e8 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -73,7 +73,7 @@ int tclTraceExec = 0;
  * disjoint for backward-compatability reasons.
  */
 
-static const char *operatorStrings[] = {
+static const char *const operatorStrings[] = {
     "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
     "+", "-", "*", "/", "%", "+", "-", "~", "!",
     "BUILTIN FUNCTION", "FUNCTION",
@@ -86,7 +86,7 @@ static const char *operatorStrings[] = {
  */
 
 #ifdef TCL_COMPILE_DEBUG
-static const char *resultStrings[] = {
+static const char *const resultStrings[] = {
     "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
 };
 #endif
@@ -7710,10 +7710,12 @@ IllegalExprOperandType(
     ClientData ptr;
     int type;
     unsigned char opcode = *pc;
-    const char *description, *operator = operatorStrings[opcode - INST_LOR];
+    const char *description, *operator = "unknown";
 
     if (opcode == INST_EXPON) {
 	operator = "**";
+    } else if (opcode <= INST_STR_NEQ) {
+	operator = operatorStrings[opcode - INST_LOR];
     }
 
     if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
-- 
cgit v0.12


From 347264f196f57e2f4433f33dbaa6c8e2e4a2c83d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 2 Feb 2014 14:42:12 +0000
Subject: improve the disassembly

---
 generic/tclCompile.c | 7 ++++++-
 generic/tclCompile.h | 3 ++-
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 08a7a4c..c5d0107 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -644,7 +644,7 @@ InstructionDesc const tclInstructionTable[] = {
     {"tryCvtToBoolean",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Try converting stktop to boolean if possible. No errors.
 	 * Stack:  ... value => ... value isStrictBool */
-    {"strclass",	 2,	0,	  1,	{OPERAND_UINT1}},
+    {"strclass",	 2,	0,	  1,	{OPERAND_SCLS1}},
 	/* See if all the characters of the given string are a member of the
 	 * specified (by opnd) character class. Note that an empty string will
 	 * satisfy the class check (standard definition of "all").
@@ -5097,6 +5097,11 @@ FormatInstruction(
 	    }
 	    Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
 	    break;
+	case OPERAND_SCLS1:
+	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+	    Tcl_AppendPrintfToObj(bufferObj, "%s ",
+		    tclStringClassTable[opnd].name);
+	    break;
 	case OPERAND_NONE:
 	default:
 	    break;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 502a2e6..5665ca9 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -825,8 +825,9 @@ typedef enum InstOperandType {
 				 * variable table. */
     OPERAND_LVT4,		/* Four byte unsigned index into the local
 				 * variable table. */
-    OPERAND_AUX4		/* Four byte unsigned index into the aux data
+    OPERAND_AUX4,		/* Four byte unsigned index into the aux data
 				 * table. */
+    OPERAND_SCLS1		/* Index into tclStringClassTable. */
 } InstOperandType;
 
 typedef struct InstructionDesc {
-- 
cgit v0.12


From 009a17d3a03061610a2c281f18937e78e995855f Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 3 Feb 2014 14:43:52 +0000
Subject: Fix [651e828a52]: Wrong Windows version reported for Windows 8.1

---
 unix/tclUnixInit.c | 29 ++++++++++++++++++++++-------
 win/tclWinInit.c   | 18 ++++++++++++++----
 2 files changed, 36 insertions(+), 11 deletions(-)

diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index 0b98cf9..423e97e 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -33,7 +33,10 @@
 #endif
 
 #ifdef __CYGWIN__
-DLLIMPORT extern __stdcall unsigned char GetVersionExA(void *);
+DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *);
+DLLIMPORT extern __stdcall void *LoadLibraryW(const void *);
+DLLIMPORT extern __stdcall void FreeLibrary(void *);
+DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *);
 DLLIMPORT extern __stdcall void GetSystemInfo(void *);
 
 #define NUMPLATFORMS 4
@@ -66,14 +69,14 @@ typedef struct _SYSTEM_INFO {
   int      wProcessorRevision;
 } SYSTEM_INFO;
 
-typedef struct _OSVERSIONINFOA {
+typedef struct _OSVERSIONINFOW {
   DWORD dwOSVersionInfoSize;
   DWORD dwMajorVersion;
   DWORD dwMinorVersion;
   DWORD dwBuildNumber;
   DWORD dwPlatformId;
-  char szCSDVersion[128];
-} OSVERSIONINFOA;
+  wchar_t szCSDVersion[128];
+} OSVERSIONINFOW;
 #endif
 
 #ifdef HAVE_COREFOUNDATION
@@ -811,7 +814,8 @@ TclpSetVariables(
 {
 #ifdef __CYGWIN__
     SYSTEM_INFO sysInfo;
-    OSVERSIONINFOA osInfo;
+    static OSVERSIONINFOW osInfo;
+    static int osInfoInitialized = 0;
     char buffer[TCL_INTEGER_SPACE * 2];
 #elif !defined(NO_UNAME)
     struct utsname name;
@@ -924,8 +928,19 @@ TclpSetVariables(
     unameOK = 0;
 #ifdef __CYGWIN__
 	unameOK = 1;
-    osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
-    GetVersionExA(&osInfo);
+    if (!osInfoInitialized) {
+      HANDLE handle = LoadLibraryW(L"NTDLL");
+      int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion");
+      osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
+      if (!getversion || getversion(&osInfo)) {
+        GetVersionExW(&osInfo);
+      }
+      if (handle) {
+        FreeLibrary(handle);
+      }
+      osInfoInitialized = 1;
+    }
+
     GetSystemInfo(&sysInfo);
 
     if (osInfo.dwPlatformId < NUMPLATFORMS) {
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index 81d762f..08ef1ed 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -563,7 +563,8 @@ TclpSetVariables(
 	SYSTEM_INFO info;
 	OemId oemId;
     } sys;
-    OSVERSIONINFOW osInfo;
+    static OSVERSIONINFOW osInfo;
+    static int osInfoInitialized = 0;
     Tcl_DString ds;
     WCHAR szUserName[UNLEN+1];
     DWORD cchUserNameLen = UNLEN;
@@ -571,9 +572,18 @@ TclpSetVariables(
     Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
 	    TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
 
-    osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
-    GetVersionExW(&osInfo);
-
+    if (!osInfoInitialized) {
+      HANDLE handle = LoadLibraryW(L"NTDLL");
+      int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion");
+      osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
+      if (!getversion || getversion(&osInfo)) {
+        GetVersionExW(&osInfo);
+      }
+      if (handle) {
+        FreeLibrary(handle);
+      }
+      osInfoInitialized = 1;
+    }
     GetSystemInfo(&sys.info);
 
     /*
-- 
cgit v0.12