Merge 8.6

9 files changed, 59 insertions, 55 deletions

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f38e752..2af30a6 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5571,16 +5571,10 @@ TEBCresume(
 	    objResultPtr = Tcl_NewStringObj((const char *)
 		    valuePtr->bytes+index, 1);
 	} else {
-	    char buf[4] = "";
+	    char buf[8] = "";
 	    Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index);
 
-	    /*
-	     * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
-	     * but creating the object as a string seems to be faster in
-	     * practical use.
-	     */
-
-	    length = Tcl_UniCharToUtf(ch, buf);
+	    length = TclUCS4ToUtf(ch, buf);
 	    objResultPtr = Tcl_NewStringObj(buf, length);
 	}
 
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index a14ce71..03d27b0 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -623,24 +623,26 @@ Tcl_NumUtfChars(
 	const char *endPtr = src + length - TCL_UTF_MAX;
 
 	while (src < endPtr) {
+#if TCL_UTF_MAX < 4
 	    if (((unsigned)UCHAR(*src) - 0xF0) < 5) {
 		/* treat F0 - F4 as single character */
 		ch = 0;
 		src++;
-	    } else {
-		src += TclUtfToUniChar(src, &ch);
-	    }
+	    } else
+#endif
+	    src += TclUtfToUniChar(src, &ch);
 	    i++;
 	}
 	endPtr += TCL_UTF_MAX;
 	while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) {
+#if TCL_UTF_MAX < 4
 	    if (((unsigned)UCHAR(*src) - 0xF0) < 5) {
 		/* treat F0 - F4 as single character */
 		ch = 0;
 		src++;
-	    } else {
-		src += TclUtfToUniChar(src, &ch);
-	    }
+	    } else
+#endif
+	    src += TclUtfToUniChar(src, &ch);
 	    i++;
 	}
 	if (src < endPtr) {
diff --git a/tests/main.test b/tests/main.test
index b0edb84..c4bb48d 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -613,7 +613,7 @@ namespace eval ::tcl::test::main {
 	variable wait
 	chan event $f readable \
 		[list set [namespace which -variable wait] "child exit"]
-	set id [after 2000 [list set [namespace which -variable wait] timeout]]
+	set id [after 5000 [list set [namespace which -variable wait] timeout]]
 	vwait [namespace which -variable wait]
 	after cancel $id
 	set wait
@@ -636,7 +636,7 @@ namespace eval ::tcl::test::main {
 	variable wait
 	chan event $f readable \
 		[list set [namespace which -variable wait] "child exit"]
-	set id [after 2000 [list set [namespace which -variable wait] timeout]]
+	set id [after 5000 [list set [namespace which -variable wait] timeout]]
 	vwait [namespace which -variable wait]
 	after cancel $id
 	set wait
@@ -719,7 +719,7 @@ namespace eval ::tcl::test::main {
     } -result "Exit MainLoop\nIn exit\neven 0\n"
 
     test Tcl_Main-5.9 {
-	Tcl_Main: interactive mode: delete interp 
+	Tcl_Main: interactive mode: delete interp
 		-> main loop & exit handlers, but no [exit]
     } -constraints {
 	exec Tcltest
diff --git a/tests/set-old.test b/tests/set-old.test
index 6138ed8..309abaf 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -940,7 +940,7 @@ catch {rename foo {}}
 
 # cleanup
 ::tcltest::cleanupTests
-return 
+return
 
 # Local Variables:
 # mode: tcl
diff --git a/tests/set.test b/tests/set.test
index 374ff7a..3c87000 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -561,7 +561,7 @@ catch {unset i}
 catch {unset x}
 catch {unset z}
 ::tcltest::cleanupTests
-return 
+return
 
 # Local Variables:
 # mode: tcl
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 8209142..49f268e 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -414,10 +414,10 @@ test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} testobj {
     list [string length $a] [string length $a]
 } {6 6}
 test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
-    string length "\u00ae" 
+    string length "\u00ae"
 } 1
 test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj {
-    # string length "￮￮" 
+    # string length "￮￮"
     # Use \uXXXX notation below instead of hardcoding the values, otherwise
     # the test will fail in multibyte locales.
     string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE"
diff --git a/tests/subst.test b/tests/subst.test
index 2115772..189dfe8 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -91,29 +91,29 @@ test subst-5.4 {command substitutions} {
 } {1 {invalid command name "bogus_command"}}
 test subst-5.5 {command substitutions} {
     set a 0
-    list [catch {subst {[set a 1}} msg] $a $msg 
+    list [catch {subst {[set a 1}} msg] $a $msg
 } {1 0 {missing close-bracket}}
 test subst-5.6 {command substitutions} {
     set a 0
-    list [catch {subst {0[set a 1}} msg] $a $msg 
+    list [catch {subst {0[set a 1}} msg] $a $msg
 } {1 0 {missing close-bracket}}
 test subst-5.7 {command substitutions} {
     set a 0
-    list [catch {subst {0[set a 1; set a 2}} msg] $a $msg 
+    list [catch {subst {0[set a 1; set a 2}} msg] $a $msg
 } {1 1 {missing close-bracket}}
 
 # repeat the tests above simulating cmd line input
 test subst-5.8 {command substitutions} {
     set script {[subst {[set a 1}]}
-    list [catch {exec [info nameofexecutable] << $script} msg] $msg 
+    list [catch {exec [info nameofexecutable] << $script} msg] $msg
 } {1 {missing close-bracket}}
 test subst-5.9 {command substitutions} {
     set script {[subst {0[set a 1}]}
-    list [catch {exec [info nameofexecutable] << $script} msg] $msg 
+    list [catch {exec [info nameofexecutable] << $script} msg] $msg
 } {1 {missing close-bracket}}
 test subst-5.10 {command substitutions} {
     set script {[subst {0[set a 1; set a 2}]}
-    list [catch {exec [info nameofexecutable] << $script} msg] $msg 
+    list [catch {exec [info nameofexecutable] << $script} msg] $msg
 } {1 {missing close-bracket}}
 
 test subst-6.1 {clear the result after command substitution} -body {
diff --git a/tests/unknown.test b/tests/unknown.test
index e80d3a6..6c31c3d 100644
--- a/tests/unknown.test
+++ b/tests/unknown.test
@@ -58,7 +58,7 @@ test unknown-4.1 {errors in "unknown" procedure} {
 catch {rename unknown {}}
 catch {rename unknown.old unknown}
 cleanupTests
-return 
+return
 
 # Local Variables:
 # mode: tcl
diff --git a/tests/utf.test b/tests/utf.test
index 71b4978..3bf8c42 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -29,7 +29,6 @@ testConstraint pre388 [eq \x741 A]
 testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]]
 		&& [string length [teststringbytes \uD83D\uDCA9]] == 4}]
 
-testConstraint teststringbytes [llength [info commands teststringbytes]]
 testConstraint testbytestring [llength [info commands testbytestring]]
 testConstraint testfindfirst [llength [info commands testfindfirst]]
 testConstraint testfindlast [llength [info commands testfindlast]]
@@ -494,18 +493,27 @@ test utf-6.91.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext ucs2} {
 test utf-6.91.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext fullutf} {
     testutfnext \xF4\x90\x80\x80
 } 1
-test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} testutfnext {
+test utf-6.92.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext ucs2} {
     testutfnext \xA0\xA0\xA0
 } 1
-test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} testutfnext {
+test utf-6.92.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext fullutf knownBug} {
+    testutfnext \xA0\xA0\xA0
+} 3
+test utf-6.93.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext ucs2} {
     testutfnext \x80\x80\x80
-} 1
-test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} testutfnext {
+} 3
+test utf-6.93.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext fullutf knownBug} {
+    testutfnext \x80\x80\x80
+} 3
+test utf-6.94.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext ucs2} {
     testutfnext \xA0\xA0\xA0\xA0
 } 1
+test utf-6.94.1 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext fullutf knownBug} {
+    testutfnext \xA0\xA0\xA0\xA0
+} 3
 test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext ucs2} {
     testutfnext \x80\x80\x80\x80
-} 1
+} 3
 test utf-6.96 {Tcl_UtfNext, read limits} testutfnext {
     testutfnext G 0
 } 0
@@ -611,16 +619,16 @@ test utf-6.121 {Tcl_UtfNext, read limits} {testutfnext ucs2} {
 test utf-6.122 {Tcl_UtfNext, read limits} {testutfnext ucs2} {
     testutfnext \xA0\xA0\xA0 2
 } 0
-test utf-6.123 {Tcl_UtfNext, read limits} testutfnext {
+test utf-6.123 {Tcl_UtfNext, read limits} {testutfnext ucs2} {
     testutfnext \xA0\xA0\xA0G 3
 } 1
-test utf-6.124 {Tcl_UtfNext, read limits} testutfnext {
+test utf-6.124 {Tcl_UtfNext, read limits} {testutfnext ucs2} {
     testutfnext \xA0\xA0\xA0\xA0 3
 } 1
-test utf-6.125 {Tcl_UtfNext, read limits} testutfnext {
+test utf-6.125 {Tcl_UtfNext, read limits} {testutfnext ucs2} {
     testutfnext \xA0\xA0\xA0\xA0G 4
 } 1
-test utf-6.126 {Tcl_UtfNext, read limits} testutfnext {
+test utf-6.126 {Tcl_UtfNext, read limits} {testutfnext ucs2} {
     testutfnext \xA0\xA0\xA0\xA0\xA0 4
 } 1
 
@@ -985,12 +993,12 @@ test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
 test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 {
     string index \uD842 0
 } \uD842
-test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} {teststringbytes ucs4} {
-    teststringbytes [string index \uD842 0]
-} \xF0
-test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} {teststringbytes tip389} {
-    teststringbytes [string index \uD842 0]
-} \xF0
+test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 {
+    string index \uD842 0
+} \uD842
+test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} tip389 {
+    string index \uD842 0
+} \uD842
 test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} {
     string index \uDC42 0
 } \uDC42
@@ -1000,18 +1008,18 @@ test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
 test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
     string index \uD83D\uDE00G 0
 } \U1F600
-test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} {teststringbytes tip389} {
-    teststringbytes [string index \uD83D\uDE00G 0]
-} \xF0
+test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} {tip389 knownBug} {
+    string index \uD83D\uDE00G 0
+} \U1F600
 test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
     string index \uD83D\uDE00G 1
 } \uDE00
 test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
     string index \uD83D\uDE00G 1
 } G
-test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} {teststringbytes tip389} {
-     teststringbytes [string index \uD83D\uDE00G 1]
-} \xED\xB8\x80
+test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} {tip389 knownBug} {
+    string index \uD83D\uDE00G 1
+} {}
 test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
     string index \uD83D\uDE00G 2
 } G
@@ -1027,18 +1035,18 @@ test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
 test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
     string index \U1F600G 0
 } \U1F600
-test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc teststringbytes tip389} {
-    teststringbytes [string index \U1F600G 0]
-} \xF0
+test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc tip389 knownBug} {
+    string index \U1F600G 0
+} \U1F600
 test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
     string index \U1F600G 1
 } G
 test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
     string index \U1F600G 1
 } G
-test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc tip389} {
+test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc tip389 knownBug} {
     string index \U1F600G 1
-} \uDE00
+} {}
 test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
     string index \U1F600G 2
 } {}