From 40ce2eccbc52b403d4a4b7bc479fbde987a14e18 Mon Sep 17 00:00:00 2001
From: fvogel <fvogelnew1@free.fr>
Date: Tue, 24 Oct 2017 21:24:07 +0000
Subject: 'array for' implementation (TIP #421) from Brad Lanam

---
 doc/array.n        |   7 +
 generic/tclVar.c   | 388 +++++++++++++++++++++++++++++++++++++++++++++++++----
 tests/set-old.test |   6 +-
 tests/var.test     | 160 +++++++++++++++++++++-
 4 files changed, 528 insertions(+), 33 deletions(-)

diff --git a/doc/array.n b/doc/array.n
index 25ad0c6..751c688 100644
--- a/doc/array.n
+++ b/doc/array.n
@@ -47,6 +47,13 @@ been the return value from a previous invocation of
 Returns 1 if \fIarrayName\fR is an array variable, 0 if there
 is no variable by that name or if it is a scalar variable.
 .TP
+\fBarray for {\fIkeyVariable ?valueVariable?\fB} \fIarrayName body\fR
+The first argument is a one or two element list of variable names for the
+key and value of each entry in the array.  The second argument is the
+array name to iterate over.  The third argument is the body to execute
+for each key and value returned.
+The ordering of the returned keys is undefined.
+.TP
 \fBarray get \fIarrayName\fR ?\fIpattern\fR?
 Returns a list containing pairs of elements.  The first
 element in each pair is the name of an element in \fIarrayName\fR
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 3dd6790..d6f3e96 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -165,6 +165,7 @@ typedef struct ArraySearch {
     struct ArraySearch *nextPtr;/* Next in list of all active searches for
 				 * this variable, or NULL if this is the last
 				 * one. */
+    Tcl_Obj *arrayNameObj;      /* name of the array object */
 } ArraySearch;
 
 /*
@@ -173,6 +174,8 @@ typedef struct ArraySearch {
 
 static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
 			    Tcl_Obj *patternPtr, int includeLinks);
+static void             ArrayDoneSearch (Interp *iPtr, Var *varPtr, ArraySearch *searchPtr);
+static Tcl_NRPostProc   ArrayForLoopCallback;
 static void		DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
 static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
 			    Var *varPtr, int flags, int index);
@@ -3098,6 +3101,321 @@ TclArraySet(
 /*
  *----------------------------------------------------------------------
  *
+ * ArrayForNRCmd
+ * ArrayForLoopCallback
+ * ArrayObjFirst
+ * ArrayObjNext
+ *
+ *  These functions implement the "array for" Tcl command.
+ *    array for {k v} a {}
+ *  The array for command iterates over the array, setting the
+ *  the specified loop variables, and executing the body each iteration.
+ *
+ *  ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
+ *  inside the structure and calls VarHashFirstEntry to start the hash
+ *  iteration.
+ *
+ *  ArrayForNRCmd() does not execute the body or set the loop variables,
+ *  it only initializes the iterator.
+ *
+ *  ArrayForLoopCallback() iterates over the entire array, executing
+ *  the body each time.
+ *
+ *  ArrayObjFirst() Does not execute the body or set the key/value variables.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+ArrayObjFirst(
+    Tcl_Interp *interp,
+    Tcl_Obj *arrayNameObj,
+    Var *varPtr,
+    ArraySearch *searchPtr)
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_HashEntry   *hPtr;
+    int             isNew;
+
+    searchPtr->varPtr = varPtr;
+    searchPtr->arrayNameObj = arrayNameObj;
+
+    /* add the search to the search table */
+    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
+    if (isNew) {
+	searchPtr->id = 1;
+	varPtr->flags |= VAR_SEARCH_ACTIVE;
+        searchPtr->nextPtr = NULL;
+    } else {
+	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
+	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
+    }
+    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
+	    &searchPtr->search);
+    Tcl_SetHashValue(hPtr, searchPtr);
+}
+
+int
+ArrayObjNext(
+    Tcl_Interp *interp,
+    Var *varPtr,                /* array */
+    ArraySearch *searchPtr,
+    Tcl_Obj **keyPtrPtr,	/* Pointer to a variable to have the key
+				 * written into, or NULL. */
+    Tcl_Obj **valuePtrPtr	/* Pointer to a variable to have the
+				 * value written into, or NULL.*/
+    )
+{
+    Tcl_Obj *keyObj;
+    Tcl_Obj *valueObj = NULL;
+    int     gotValue;
+    int     donerc;
+
+    donerc = TCL_BREAK;
+
+    if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
+      donerc = TCL_ERROR;
+      return donerc;
+    }
+
+    gotValue = 0;
+    while (1) {
+	Tcl_HashEntry *hPtr = searchPtr->nextEntry;
+        if (hPtr != NULL) {
+          searchPtr->nextEntry = NULL;
+        } else {
+          hPtr = Tcl_NextHashEntry(&searchPtr->search);
+          if (hPtr == NULL) {
+            gotValue = 0;
+            break;
+          }
+        }
+	varPtr = VarHashGetValue(hPtr);
+	if (!TclIsVarUndefined(varPtr)) {
+	    gotValue = 1;
+	    break;
+	}
+    }
+
+    if (! gotValue) {
+	return donerc;
+    }
+
+    donerc = TCL_CONTINUE;
+
+    keyObj = VarHashGetKey(varPtr);
+    *keyPtrPtr = keyObj;
+    valueObj = Tcl_ObjGetVar2(interp, searchPtr->arrayNameObj,
+        keyObj, TCL_LEAVE_ERR_MSG);
+    *valuePtrPtr = valueObj;
+
+    return donerc;
+}
+
+static int
+ArrayForNRCmd(
+    ClientData dummy,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
+    Tcl_Obj **varv;
+    Tcl_Obj *arrayNameObj;
+    ArraySearch *searchPtr = NULL;
+    Var *varPtr;
+    Var *arrayPtr;
+    int varc;
+
+    /*
+     * array for {k v} a body
+     */
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 1, objv,
+		"{key value} arrayName script");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Parse arguments.
+     */
+
+    if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (varc != 2) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"must have two variable names", -1));
+	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
+	return TCL_ERROR;
+    }
+
+    arrayNameObj = objv[2];
+    keyVarObj = varv[0];
+    valueVarObj = varv[1];
+    scriptObj = objv[3];
+
+    /*
+     * Locate the array variable.
+     */
+
+    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
+	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+    /*
+     * Special array trace used to keep the env array in sync for array names,
+     * array get, etc.
+     */
+
+    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL,
+		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
+	    return TCL_ERROR;
+	}
+    }
+
+    /*
+     * Verify that it is indeed an array variable. This test comes after the
+     * traces; the variable may actually become an array as an effect of said
+     * traces.
+     */
+
+    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+	    || TclIsVarUndefined(varPtr)) {
+	const char *varName = Tcl_GetString(arrayNameObj);
+
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"\"%s\" isn't an array", varName));
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make a new array search, put it on the stack.
+     */
+
+    searchPtr = ckalloc(sizeof(ArraySearch));
+    searchPtr->arrayNameObj = NULL;
+    ArrayObjFirst(interp, arrayNameObj, varPtr, searchPtr);
+
+    /*
+     * Make sure that these objects (which we need throughout the body of the
+     * loop) don't vanish.
+     */
+
+    Tcl_IncrRefCount(keyVarObj);
+    Tcl_IncrRefCount(valueVarObj);
+    Tcl_IncrRefCount(scriptObj);
+
+    /*
+     * Run the script.
+     */
+
+    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, keyVarObj,
+	    valueVarObj, scriptObj);
+    return TCL_OK;
+}
+
+static int
+ArrayForLoopCallback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    ArraySearch *searchPtr = data[0];
+    Tcl_Obj *keyVarObj = data[1];
+    Tcl_Obj *valueVarObj = data[2];
+    Tcl_Obj *scriptObj = data[3];
+    Tcl_Obj *keyObj, *valueObj;
+    Var *varPtr;
+    Var *arrayPtr;
+    int done;
+
+    /*
+     * Process the result from the previous execution of the script body.
+     */
+
+    done = TCL_ERROR;
+    varPtr = TclObjLookupVarEx(interp, searchPtr->arrayNameObj, NULL, /*flags*/ 0,
+	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+    if (result == TCL_CONTINUE) {
+	result = TCL_OK;
+    } else if (result != TCL_OK) {
+	if (result == TCL_BREAK) {
+	    Tcl_ResetResult(interp);
+	    result = TCL_OK;
+	} else if (result == TCL_ERROR) {
+	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		    "\n    (\"array for\" body line %d)",
+		    Tcl_GetErrorLine(interp)));
+	}
+	goto arrayfordone;
+    }
+
+    /*
+     * Get the next mapping from the array.
+     */
+
+    keyObj = NULL;
+    valueObj = NULL;
+    done = ArrayObjNext (interp, varPtr, searchPtr, &keyObj, &valueObj);
+
+    result = TCL_OK;
+    if (done != TCL_CONTINUE) {
+	Tcl_ResetResult(interp);
+        if (done == TCL_ERROR) {
+          varPtr->flags |= TCL_LEAVE_ERR_MSG;
+          Tcl_AddErrorInfo(interp, "array changed during iteration");
+          result = done;
+        }
+	goto arrayfordone;
+    }
+    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
+      result = TCL_ERROR;
+      goto arrayfordone;
+    }
+    if (valueObj != NULL) {
+      if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
+        result = TCL_ERROR;
+        goto arrayfordone;
+      }
+    }
+
+    /*
+     * Run the script.
+     */
+
+    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, keyVarObj,
+	    valueVarObj, scriptObj);
+    return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
+
+    /*
+     * For unwinding everything once the iterating is done.
+     */
+
+  arrayfordone:
+    /* if the search was terminated by an array change, the
+     * VAR_SEARCH_ACTIVE flag will no longer be set
+     */
+    if (done != TCL_ERROR) {
+      ArrayDoneSearch (iPtr, varPtr, searchPtr);
+      ckfree(searchPtr);
+    }
+
+    TclDecrRefCount(keyVarObj);
+    TclDecrRefCount(valueVarObj);
+    TclDecrRefCount(scriptObj);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * ArrayStartSearchCmd --
  *
  *	This object-based function is invoked to process the "array
@@ -3197,6 +3515,50 @@ ArrayStartSearchCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * ArrayDoneSearch --
+ *
+ *      Removes the search from the hash of active searches.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+ArrayDoneSearch (
+    Interp *iPtr,
+    Var *varPtr,
+    ArraySearch *searchPtr)
+{
+    Tcl_HashEntry *hPtr;
+    ArraySearch *prevPtr;
+
+    /*
+     * Unhook the search from the list of searches associated with the
+     * variable.
+     */
+
+    hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
+    if (hPtr == NULL) {
+      return;
+    }
+    if (searchPtr == Tcl_GetHashValue(hPtr)) {
+	if (searchPtr->nextPtr) {
+	    Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
+	} else {
+	    varPtr->flags &= ~VAR_SEARCH_ACTIVE;
+	    Tcl_DeleteHashEntry(hPtr);
+	}
+    } else {
+	for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
+	    if (prevPtr->nextPtr == searchPtr) {
+		prevPtr->nextPtr = searchPtr->nextPtr;
+		break;
+	    }
+	}
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * ArrayAnyMoreCmd --
  *
  *	This object-based function is invoked to process the "array anymore"
@@ -3437,9 +3799,8 @@ ArrayDoneSearchCmd(
 {
     Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr;
-    Tcl_HashEntry *hPtr;
     Tcl_Obj *varNameObj, *searchObj;
-    ArraySearch *searchPtr, *prevPtr;
+    ArraySearch *searchPtr;
 
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
@@ -3493,27 +3854,7 @@ ArrayDoneSearchCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Unhook the search from the list of searches associated with the
-     * variable.
-     */
-
-    hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
-    if (searchPtr == Tcl_GetHashValue(hPtr)) {
-	if (searchPtr->nextPtr) {
-	    Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
-	} else {
-	    varPtr->flags &= ~VAR_SEARCH_ACTIVE;
-	    Tcl_DeleteHashEntry(hPtr);
-	}
-    } else {
-	for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
-	    if (prevPtr->nextPtr == searchPtr) {
-		prevPtr->nextPtr = searchPtr->nextPtr;
-		break;
-	    }
-	}
-    }
+    ArrayDoneSearch (iPtr, varPtr, searchPtr);
     ckfree(searchPtr);
     return TCL_OK;
 }
@@ -4372,6 +4713,7 @@ TclInitArrayCmd(
 	{"anymore",	ArrayAnyMoreCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
 	{"donesearch",	ArrayDoneSearchCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
 	{"exists",	ArrayExistsCmd,		TclCompileArrayExistsCmd, NULL, NULL, 0},
+	{"for",		NULL,			TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
 	{"get",		ArrayGetCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
 	{"names",	ArrayNamesCmd,		TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
 	{"nextelement",	ArrayNextElementCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
diff --git a/tests/set-old.test b/tests/set-old.test
index 6138ed8..3b4184c 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -340,7 +340,7 @@ test set-old-8.6 {array command} {
     catch {unset a}
     set a(22) 3
     list [catch {array gorp a} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}}
+} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}}
 test set-old-8.7 {array command, anymore option} {
     catch {unset a}
     list [catch {array anymore a x} msg] $msg
@@ -652,7 +652,7 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} {
     set a(11) 1
     list [catch {lsort [array names a -regexp ^1]} msg] $msg
 } {0 {1*2 11 12}}
-test set-old-8.52.1 {array command, array names -regexp, backrefs} {
+?test set-old-8.52.1 {array command, array names -regexp, backrefs} {
     catch {unset a}
     set a(1*2) 1
     set a(12) 1
@@ -940,7 +940,7 @@ catch {rename foo {}}
 
 # cleanup
 ::tcltest::cleanupTests
-return 
+return
 
 # Local Variables:
 # mode: tcl
diff --git a/tests/var.test b/tests/var.test
index a9d93ac..630202a 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -53,7 +53,7 @@ catch {unset arr}
 test var-1.1 {TclLookupVar, Array handling} -setup {
     catch {unset a}
 } -body {
-    set x "incr"  ;# force no compilation and runtime call to Tcl_IncrCmd 
+    set x "incr"  ;# force no compilation and runtime call to Tcl_IncrCmd
     set i 10
     set arr(foo) 37
     list [$x i] $i [$x arr(foo)] $arr(foo)
@@ -234,7 +234,7 @@ test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup {
     set a 123321
     proc p {} {
 	# create global xx linked to global a
-	testupvar 1 a {} xx global 
+	testupvar 1 a {} xx global
     }
     list [p] $xx [set xx 789] $a
 } -result {{} 123321 789 789}
@@ -246,7 +246,7 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup {
 	catch {unset ::test_ns_var::vv}
 	proc p {} {
 	    # create namespace var vv linked to global a
-	    testupvar 1 a {} vv namespace 
+	    testupvar 1 a {} vv namespace
 	}
 	p
     }
@@ -548,11 +548,11 @@ test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body {
     namespace eval test_ns_var { variable arrayvar(1) }
 } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array"
 test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body {
-    namespace eval test_ns_var { 
+    namespace eval test_ns_var {
 	variable arrayvar
 	set arrayvar(1) x
 	variable arrayvar(1) y
-    }   
+    }
 } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array"
 test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} {
     variable
@@ -790,7 +790,7 @@ test var-15.1 {segfault in [unset], [Bug 735335]} {
 	set var $name
     }
     #
-    # Note that the variable name has to be 
+    # Note that the variable name has to be
     # unused previously for the segfault to
     # be triggered.
     #
@@ -997,7 +997,153 @@ test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
     rename getbytes {}
     rename doit {}
 } -result 0
-
+
+unset -nocomplain a k v
+test var-23.1 {array command, for loop, too many args} -returnCodes error -body {
+    array for {k v} c d e {}
+} -result {wrong # args: should be "array for {key value} arrayName script"}
+test var-23.2 {array command, for loop, not enough args} -returnCodes error -body {
+    array for {k v} {}
+} -result {wrong # args: should be "array for {key value} arrayName script"}
+test var-23.3 {array command, for loop, too many list args} -setup {
+    unset -nocomplain a
+} -returnCodes error -body {
+    array for {k v w} a {}
+} -result {must have two variable names}
+test var-23.4 {array command, for loop, not enough list args} -setup {
+    unset -nocomplain a
+} -returnCodes error -body {
+    array for {k} a {}
+} -result {must have two variable names}
+test var-23.5 {array command, for loop, no array} -setup {
+    unset -nocomplain a
+} -returnCodes error -body {
+    array for {k v} a {}
+} -result {"a" isn't an array}
+test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup {
+    catch {rename p ""}
+} -returnCodes error -body {
+    apply {{x} {
+        if {$x==1} {
+            return [array for {k v} a {}]
+        }
+        set a(x) 123
+    }} 1
+} -result {"a" isn't an array}
+test var-23.7 {array enumeration} -setup {
+    unset -nocomplain a
+    set reslist [list]
+} -body {
+    array set a {a 1 b 2 c 3}
+    array for {k v} a {
+	lappend reslist $k $v
+    }
+    lsort -stride 2 -index 0 $reslist
+} -cleanup {
+    unset -nocomplain a
+    unset -nocomplain reslist
+} -result {a 1 b 2 c 3}
+test var-23.9 {array enumeration, nested} -setup {
+    unset -nocomplain a
+    set reslist [list]
+} -body {
+    array set a {a 1 b 2 c 3}
+    array for {k1 v1} a {
+	lappend reslist $k1 $v1
+	set r2 {}
+	array for {k2 v2} a {
+	    lappend r2 $k2 $v2
+	}
+	lappend reslist [lsort -stride 2 -index 0 $r2]
+    }
+    # there is no guarantee in which order the array contents will be
+    # returned.
+    lsort -stride 3 -index 0 $reslist
+} -cleanup {
+    unset -nocomplain a
+    unset -nocomplain reslist
+} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}}
+test var-23.10 {array enumeration, delete key} -match glob -setup {
+    unset -nocomplain a
+    set reslist [list]
+} -body {
+    set retval {}
+    try {
+      array set a {a 1 b 2 c 3 d 4}
+      array for {k v} a {
+  	lappend reslist $k $v
+          if { $k eq "a" } {
+            unset a(c)
+          }
+      }
+      lsort -stride 2 -index 0 $reslist
+    } on error {err res} {
+      set retval [dict get $res -errorinfo]
+    }
+    set retval
+} -cleanup {
+    unset -nocomplain a
+    unset -nocomplain reslist
+    unset -nocomplain retval
+} -result {array changed during iteration*}
+test var-23.11 {array enumeration, insert key} -match glob -setup {
+    unset -nocomplain a
+    set reslist [list]
+} -body {
+    set retval {}
+    try {
+      array set a {a 1 b 2 c 3 d 4}
+      array for {k v} a {
+  	lappend reslist $k $v
+          if { $k eq "a" } {
+            set a(e) 5
+          }
+      }
+      lsort -stride 2 -index 0 $reslist
+    } on error {err res} {
+      set retval [dict get $res -errorinfo]
+    }
+} -cleanup {
+    unset -nocomplain a
+    unset -nocomplain reslist
+} -result {array changed during iteration*}
+test var-23.12 {array enumeration, change value} -setup {
+    unset -nocomplain a
+    set reslist [list]
+} -body {
+    array set a {a 1 b 2 c 3}
+    array for {k v} a {
+	lappend reslist $k $v
+        if { $k eq "a" } {
+          set a(c) 9
+        }
+    }
+    lsort -stride 2 -index 0 $reslist
+} -cleanup {
+    unset -nocomplain a
+    unset -nocomplain reslist
+} -result {a 1 b 2 c 9}
+test var-23.13 {array enumeration, number of traces} -setup {
+    set ::countarrayfor 0
+    proc ::tracearrayfor { args } {
+      incr ::countarrayfor
+    }
+    unset -nocomplain ::a
+    set reslist [list]
+} -body {
+    array set ::a {a 1 b 2 c 3}
+    foreach {k} [array names a] {
+      trace add variable ::a($k) read ::tracearrayfor
+    }
+    array for {k v} ::a {
+	lappend reslist $k $v
+    }
+    set ::countarrayfor
+} -cleanup {
+    unset -nocomplain ::countarrayfor
+    unset -nocomplain ::a
+    unset -nocomplain reslist
+} -result 3
 
 catch {namespace delete ns}
 catch {unset arr}
-- 
cgit v0.12


From d8cae66217adcfb4920030071e54e37b5a88a1c4 Mon Sep 17 00:00:00 2001
From: fvogel <fvogelnew1@free.fr>
Date: Wed, 25 Oct 2017 17:31:09 +0000
Subject: Fix typo in set-old.test

---
 tests/set-old.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/set-old.test b/tests/set-old.test
index 3b4184c..b2e7aa6 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -652,7 +652,7 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} {
     set a(11) 1
     list [catch {lsort [array names a -regexp ^1]} msg] $msg
 } {0 {1*2 11 12}}
-?test set-old-8.52.1 {array command, array names -regexp, backrefs} {
+test set-old-8.52.1 {array command, array names -regexp, backrefs} {
     catch {unset a}
     set a(1*2) 1
     set a(12) 1
-- 
cgit v0.12


From 48b529209c87473364215e8aef740e331f88415a Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 7 Nov 2017 12:15:30 +0000
Subject: Somewhat simplified implementation of TIP #389, in which the "string
 length" if characters > U+FFFF is considered to be 2, not 1.

---
 doc/StringObj.3        |  2 +-
 doc/ToUpper.3          |  2 +-
 doc/Utf.3              |  2 +-
 generic/tcl.decls      | 10 +++---
 generic/tcl.h          |  2 +-
 generic/tclCmdMZ.c     | 18 ++++++++--
 generic/tclDecls.h     | 20 +++++------
 generic/tclScan.c      | 12 +++++--
 generic/tclStringObj.c | 12 +++----
 generic/tclUtf.c       | 95 +++++++++++++++++++++++++++++++++++---------------
 tests/string.test      | 26 +++++++-------
 tests/utf.test         |  4 +--
 12 files changed, 132 insertions(+), 73 deletions(-)

diff --git a/doc/StringObj.3 b/doc/StringObj.3
index 7042cc8..8d9bb56 100644
--- a/doc/StringObj.3
+++ b/doc/StringObj.3
@@ -37,7 +37,7 @@ Tcl_UniChar *
 Tcl_UniChar *
 \fBTcl_GetUnicode\fR(\fIobjPtr\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR)
 .sp
 int
diff --git a/doc/ToUpper.3 b/doc/ToUpper.3
index b933e9c..14766da 100644
--- a/doc/ToUpper.3
+++ b/doc/ToUpper.3
@@ -13,7 +13,7 @@ Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_
 .nf
 \fB#include <tcl.h>\fR
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharToUpper\fR(\fIch\fR)
 .sp
 Tcl_UniChar
diff --git a/doc/Utf.3 b/doc/Utf.3
index 378c806..5cd6b7df 100644
--- a/doc/Utf.3
+++ b/doc/Utf.3
@@ -63,7 +63,7 @@ const char *
 const char *
 \fBTcl_UtfPrev\fR(\fIsrc, start\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
 .sp
 const char *
diff --git a/generic/tcl.decls b/generic/tcl.decls
index b2b91a9..e3ea9bc 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -1148,16 +1148,16 @@ declare 319 {
 	    Tcl_QueuePosition position)
 }
 declare 320 {
-    Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
+    int Tcl_UniCharAtIndex(const char *src, int index)
 }
 declare 321 {
-    Tcl_UniChar Tcl_UniCharToLower(int ch)
+    int Tcl_UniCharToLower(int ch)
 }
 declare 322 {
-    Tcl_UniChar Tcl_UniCharToTitle(int ch)
+    int Tcl_UniCharToTitle(int ch)
 }
 declare 323 {
-    Tcl_UniChar Tcl_UniCharToUpper(int ch)
+    int Tcl_UniCharToUpper(int ch)
 }
 declare 324 {
     int Tcl_UniCharToUtf(int ch, char *buf)
@@ -1351,7 +1351,7 @@ declare 380 {
     int Tcl_GetCharLength(Tcl_Obj *objPtr)
 }
 declare 381 {
-    Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
+    int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
 }
 declare 382 {
     Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
diff --git a/generic/tcl.h b/generic/tcl.h
index 07d841d..f874997 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2201,7 +2201,7 @@ typedef struct Tcl_EncodingType {
  */
 
 #ifndef TCL_UTF_MAX
-#define TCL_UTF_MAX		3
+#define TCL_UTF_MAX		4
 #endif
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 2195aa1..b6a8fe9 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -309,7 +309,7 @@ Tcl_RegexpObjCmd(
 	    eflags = 0;
 	} else if (offset > stringLength) {
 	    eflags = TCL_REG_NOTBOL;
-	} else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') {
+	} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
 	    eflags = 0;
 	} else {
 	    eflags = TCL_REG_NOTBOL;
@@ -1218,6 +1218,12 @@ Tcl_SplitObjCmd(
 	for ( ; stringPtr < end; stringPtr += len) {
 	    len = TclUtfToUniChar(stringPtr, &ch);
 
+#if TCL_UTF_MAX == 4
+	    if (!len) {
+		continue;
+	    }
+#endif
+
 	    /*
 	     * Assume Tcl_UniChar is an integral type...
 	     */
@@ -1814,8 +1820,16 @@ StringIsCmd(
 	}
 	end = string1 + length1;
 	for (; string1 < end; string1 += length2, failat++) {
+	    int fullchar;
 	    length2 = TclUtfToUniChar(string1, &ch);
-	    if (!chcomp(ch)) {
+	    fullchar = ch;
+#if TCL_UTF_MAX == 4
+	    if (!length2) {
+	    	length2 = TclUtfToUniChar(string1, &ch);
+	    	fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	    }
+#endif
+	    if (!chcomp(fullchar)) {
 		result = 0;
 		break;
 	    }
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 464fc0f..5f83636 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -959,13 +959,13 @@ EXTERN void		Tcl_ThreadAlert(Tcl_ThreadId threadId);
 EXTERN void		Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
 				Tcl_Event *evPtr, Tcl_QueuePosition position);
 /* 320 */
-EXTERN Tcl_UniChar	Tcl_UniCharAtIndex(const char *src, int index);
+EXTERN int		Tcl_UniCharAtIndex(const char *src, int index);
 /* 321 */
-EXTERN Tcl_UniChar	Tcl_UniCharToLower(int ch);
+EXTERN int		Tcl_UniCharToLower(int ch);
 /* 322 */
-EXTERN Tcl_UniChar	Tcl_UniCharToTitle(int ch);
+EXTERN int		Tcl_UniCharToTitle(int ch);
 /* 323 */
-EXTERN Tcl_UniChar	Tcl_UniCharToUpper(int ch);
+EXTERN int		Tcl_UniCharToUpper(int ch);
 /* 324 */
 EXTERN int		Tcl_UniCharToUtf(int ch, char *buf);
 /* 325 */
@@ -1117,7 +1117,7 @@ EXTERN void		Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
 /* 380 */
 EXTERN int		Tcl_GetCharLength(Tcl_Obj *objPtr);
 /* 381 */
-EXTERN Tcl_UniChar	Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
+EXTERN int		Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
 /* 382 */
 EXTERN Tcl_UniChar *	Tcl_GetUnicode(Tcl_Obj *objPtr);
 /* 383 */
@@ -2186,10 +2186,10 @@ typedef struct TclStubs {
     Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
     void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
     void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */
-    Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
-    Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */
-    Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
-    Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
+    int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
+    int (*tcl_UniCharToLower) (int ch); /* 321 */
+    int (*tcl_UniCharToTitle) (int ch); /* 322 */
+    int (*tcl_UniCharToUpper) (int ch); /* 323 */
     int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
     CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
     int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
@@ -2247,7 +2247,7 @@ typedef struct TclStubs {
     Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */
     void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
     int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
-    Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
+    int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
     Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
     Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
     void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
diff --git a/generic/tclScan.c b/generic/tclScan.c
index e1fcad4..7f71262 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -885,9 +885,17 @@ Tcl_ScanObjCmd(
 	     * Scan a single Unicode character.
 	     */
 
-	    string += TclUtfToUniChar(string, &sch);
+	    offset = TclUtfToUniChar(string, &sch);
+	    i = (int)sch;
+#if TCL_UTF_MAX == 4
+	    if (!offset) {
+		offset = Tcl_UtfToUniChar(string, &sch);
+		i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF);
+	    }
+#endif
+	    string += offset;
 	    if (!(flags & SCAN_SUPPRESS)) {
-		objPtr = Tcl_NewIntObj((int)sch);
+		objPtr = Tcl_NewIntObj(i);
 		Tcl_IncrRefCount(objPtr);
 		CLANG_ASSERT(objs);
 		objs[objIndex++] = objPtr;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 3a35bcf..1ccd778 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -466,7 +466,7 @@ Tcl_GetCharLength(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_GetUniChar(
     Tcl_Obj *objPtr,		/* The object to get the Unicode charater
 				 * from. */
@@ -483,7 +483,7 @@ Tcl_GetUniChar(
     if (TclIsPureByteArray(objPtr)) {
 	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL);
 
-	return (Tcl_UniChar) bytes[index];
+	return (int) bytes[index];
     }
 
     /*
@@ -507,7 +507,7 @@ Tcl_GetUniChar(
 	FillUnicodeRep(objPtr);
 	stringPtr = GET_STRING(objPtr);
     }
-    return stringPtr->unicode[index];
+    return (int) stringPtr->unicode[index];
 }
 
 /*
@@ -3462,7 +3462,6 @@ TclStringObjReverse(
 	     * Tcl_SetObjLength into growing the unicode rep buffer.
 	     */
 
-	    ch = 0;
 	    objPtr = Tcl_NewUnicodeObj(&ch, 1);
 	    Tcl_SetObjLength(objPtr, stringPtr->numChars);
 	    to = Tcl_GetUnicode(objPtr);
@@ -3565,7 +3564,7 @@ ExtendUnicodeRepWithString(
 {
     String *stringPtr = GET_STRING(objPtr);
     int needed, numOrigChars = 0;
-    Tcl_UniChar *dst;
+    Tcl_UniChar *dst, unichar = 0;
 
     if (stringPtr->hasUnicode) {
 	numOrigChars = stringPtr->numChars;
@@ -3588,7 +3587,8 @@ ExtendUnicodeRepWithString(
 	numAppendChars = 0;
     }
     for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
-	bytes += TclUtfToUniChar(bytes, dst);
+	bytes += TclUtfToUniChar(bytes, &unichar);
+	*dst = unichar;
     }
     *dst = 0;
 }
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 25cc2d1..859fe78 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -699,7 +699,7 @@ Tcl_UtfPrev(
  *---------------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharAtIndex(
     register const char *src,	/* The UTF-8 string to dereference. */
     register int index)		/* The position of the desired character. */
@@ -819,7 +819,8 @@ int
 Tcl_UtfToUpper(
     char *str)			/* String to convert in place. */
 {
-    Tcl_UniChar ch = 0, upChar;
+    Tcl_UniChar ch = 0;
+    int upChar;
     char *src, *dst;
     int bytes;
 
@@ -830,7 +831,14 @@ Tcl_UtfToUpper(
     src = dst = str;
     while (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	upChar = Tcl_UniCharToUpper(ch);
+	upChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	upChar = Tcl_UniCharToUpper(upChar);
 
 	/*
 	 * To keep badly formed Utf strings from getting inflated by the
@@ -872,7 +880,8 @@ int
 Tcl_UtfToLower(
     char *str)			/* String to convert in place. */
 {
-    Tcl_UniChar ch = 0, lowChar;
+    Tcl_UniChar ch = 0;
+    int lowChar;
     char *src, *dst;
     int bytes;
 
@@ -883,7 +892,14 @@ Tcl_UtfToLower(
     src = dst = str;
     while (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	lowChar = Tcl_UniCharToLower(ch);
+	lowChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	lowChar = Tcl_UniCharToLower(lowChar);
 
 	/*
 	 * To keep badly formed Utf strings from getting inflated by the
@@ -926,7 +942,8 @@ int
 Tcl_UtfToTitle(
     char *str)			/* String to convert in place. */
 {
-    Tcl_UniChar ch = 0, titleChar, lowChar;
+    Tcl_UniChar ch = 0;
+    int titleChar, lowChar;
     char *src, *dst;
     int bytes;
 
@@ -939,7 +956,14 @@ Tcl_UtfToTitle(
 
     if (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	titleChar = Tcl_UniCharToTitle(ch);
+	titleChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	titleChar = Tcl_UniCharToTitle(titleChar);
 
 	if (bytes < TclUtfCount(titleChar)) {
 	    memcpy(dst, src, (size_t) bytes);
@@ -951,7 +975,14 @@ Tcl_UtfToTitle(
     }
     while (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	lowChar = Tcl_UniCharToLower(ch);
+	lowChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	lowChar = Tcl_UniCharToLower(lowChar);
 
 	if (bytes < TclUtfCount(lowChar)) {
 	    memcpy(dst, src, (size_t) bytes);
@@ -1159,16 +1190,18 @@ TclUtfCasecmp(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharToUpper(
     int ch)			/* Unicode character to convert. */
 {
-    int info = GetUniCharInfo(ch);
+    if (!UNICODE_OUT_OF_RANGE(ch)) {
+	int info = GetUniCharInfo(ch);
 
-    if (GetCaseType(info) & 0x04) {
-	ch -= GetDelta(info);
+	if (GetCaseType(info) & 0x04) {
+	    ch -= GetDelta(info);
+	}
     }
-    return (Tcl_UniChar) ch;
+    return ch & 0x1FFFFF;
 }
 
 /*
@@ -1187,16 +1220,18 @@ Tcl_UniCharToUpper(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharToLower(
     int ch)			/* Unicode character to convert. */
 {
-    int info = GetUniCharInfo(ch);
+    if (!UNICODE_OUT_OF_RANGE(ch)) {
+	int info = GetUniCharInfo(ch);
 
-    if (GetCaseType(info) & 0x02) {
-	ch += GetDelta(info);
+	if (GetCaseType(info) & 0x02) {
+	    ch += GetDelta(info);
+	}
     }
-    return (Tcl_UniChar) ch;
+    return ch & 0x1FFFFF;
 }
 
 /*
@@ -1215,23 +1250,25 @@ Tcl_UniCharToLower(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharToTitle(
     int ch)			/* Unicode character to convert. */
 {
-    int info = GetUniCharInfo(ch);
-    int mode = GetCaseType(info);
+    if (!UNICODE_OUT_OF_RANGE(ch)) {
+	int info = GetUniCharInfo(ch);
+	int mode = GetCaseType(info);
 
-    if (mode & 0x1) {
-	/*
-	 * Subtract or add one depending on the original case.
-	 */
+	if (mode & 0x1) {
+	    /*
+	     * Subtract or add one depending on the original case.
+	     */
 
-	ch += ((mode & 0x4) ? -1 : 1);
-    } else if (mode == 0x4) {
-	ch -= GetDelta(info);
+	    ch += ((mode & 0x4) ? -1 : 1);
+	} else if (mode == 0x4) {
+	    ch -= GetDelta(info);
+	}
     }
-    return (Tcl_UniChar) ch;
+    return ch & 0x1FFFFF;
 }
 
 /*
diff --git a/tests/string.test b/tests/string.test
index cb901b9..cebaf4c 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -1697,40 +1697,40 @@ test string-24.4 {string reverse command - unshared string} {
     string reverse $x$y
 } edcba
 test string-24.5 {string reverse command - shared unicode string} {
-    set x abcde\udead
+    set x abcde\ud0ad
     string reverse $x
-} \udeadedcba
+} \ud0adedcba
 test string-24.6 {string reverse command - unshared string} {
     set x abc
-    set y de\udead
+    set y de\ud0ad
     string reverse $x$y
-} \udeadedcba
+} \ud0adedcba
 test string-24.7 {string reverse command - simple case} {
     string reverse a
 } a
 test string-24.8 {string reverse command - simple case} {
-    string reverse \udead
-} \udead
+    string reverse \ud0ad
+} \ud0ad
 test string-24.9 {string reverse command - simple case} {
     string reverse {}
 } {}
 test string-24.10 {string reverse command - corner case} {
-    set x \ubeef\udead
+    set x \ubeef\ud0ad
     string reverse $x
-} \udead\ubeef
+} \ud0ad\ubeef
 test string-24.11 {string reverse command - corner case} {
     set x \ubeef
-    set y \udead
+    set y \ud0ad
     string reverse $x$y
-} \udead\ubeef
+} \ud0ad\ubeef
 test string-24.12 {string reverse command - corner case} {
     set x \ubeef
-    set y \udead
+    set y \ud0ad
     string is ascii [string reverse $x$y]
 } 0
 test string-24.13 {string reverse command - pure Unicode string} {
-    string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5]
-} \udead\ubeef\udead\ubeef\udead
+    string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5]
+} \ud0ad\ubeef\ud0ad\ubeef\ud0ad
 test string-24.14 {string reverse command - pure bytearray} {
     binary scan [string reverse [binary format H* 010203]] H* x
     set x
diff --git a/tests/utf.test b/tests/utf.test
index 422ab08..45f9c0c 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -68,10 +68,10 @@ test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestrin
 } {1}
 test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
     string length [testbytestring "\xF0\x90\x80\x80"]
-} -result {1}
+} -result {2}
 test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
     string length [testbytestring "\xF4\x8F\xBF\xBF"]
-} -result {1}
+} -result {2}
 test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
     string length [testbytestring "\xF0\x8F\xBF\xBF"]
 } {4}
-- 
cgit v0.12


From 2ea8f0fe98ed8a2f72d7d355b9c080fbb5bdd912 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 17 Nov 2017 16:08:49 +0000
Subject: merge core-8-branch. Fix some Tcl_UniChar initialization, in case
 TCL_UTF_MAX == 4

---
 doc/ToUpper.3          |  6 +++---
 doc/UniCharIsAlpha.3   |  7 ++-----
 doc/Utf.3              |  2 +-
 generic/tclScan.c      |  2 +-
 generic/tclStringObj.c | 10 +++++-----
 generic/tclUtf.c       | 34 ++++++++++++++++++++++++----------
 generic/tclUtil.c      | 14 +++++++-------
 win/tclWinSerial.c     |  6 +++---
 8 files changed, 46 insertions(+), 35 deletions(-)

diff --git a/doc/ToUpper.3 b/doc/ToUpper.3
index 14766da..b06b793 100644
--- a/doc/ToUpper.3
+++ b/doc/ToUpper.3
@@ -16,10 +16,10 @@ Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_
 int
 \fBTcl_UniCharToUpper\fR(\fIch\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharToLower\fR(\fIch\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharToTitle\fR(\fIch\fR)
 .sp
 int
@@ -33,7 +33,7 @@ int
 .SH ARGUMENTS
 .AS char *str in/out
 .AP int ch in
-The Tcl_UniChar to be converted.
+The character to be converted.
 .AP char *str in/out
 Pointer to UTF-8 string to be converted in place.
 .BE
diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3
index 2336c34..e1d23ab 100644
--- a/doc/UniCharIsAlpha.3
+++ b/doc/UniCharIsAlpha.3
@@ -48,19 +48,16 @@ int
 .SH ARGUMENTS
 .AS int ch
 .AP int ch in
-The Tcl_UniChar to be examined.
+The character to be examined.
 .BE
 
 .SH DESCRIPTION
 .PP
-All of the routines described examine Tcl_UniChars and return a
+All of the routines described examine characters and return a
 boolean value. A non-zero return value means that the character does
 belong to the character class associated with the called routine. The
 rest of this document just describes the character classes associated
 with the various routines.
-.PP
-Note: A Tcl_UniChar is a Unicode character represented as an unsigned,
-fixed-size quantity.
 
 .SH "CHARACTER CLASSES"
 .PP
diff --git a/doc/Utf.3 b/doc/Utf.3
index 5cd6b7df..638f349 100644
--- a/doc/Utf.3
+++ b/doc/Utf.3
@@ -77,7 +77,7 @@ int
 Buffer in which the UTF-8 representation of the Tcl_UniChar is stored.  At most
 \fBTCL_UTF_MAX\fR bytes are stored in the buffer.
 .AP int ch in
-The Tcl_UniChar to be converted or examined.
+The character to be converted or examined.
 .AP Tcl_UniChar *chPtr out
 Filled with the Tcl_UniChar represented by the head of the UTF-8 string.
 .AP "const char" *src in
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 7f71262..e0798df 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -889,7 +889,7 @@ Tcl_ScanObjCmd(
 	    i = (int)sch;
 #if TCL_UTF_MAX == 4
 	    if (!offset) {
-		offset = Tcl_UtfToUniChar(string, &sch);
+		offset = TclUtfToUniChar(string, &sch);
 		i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF);
 	    }
 #endif
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 1ccd778..fda6ac1 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1869,20 +1869,20 @@ Tcl_AppendFormatToObj(
 	} else if (ch == 'I') {
 	    if ((format[1] == '6') && (format[2] == '4')) {
 		format += (step + 2);
-		step = Tcl_UtfToUniChar(format, &ch);
+		step = TclUtfToUniChar(format, &ch);
 #ifndef TCL_WIDE_INT_IS_LONG
 		useWide = 1;
 #endif
 	    } else if ((format[1] == '3') && (format[2] == '2')) {
 		format += (step + 2);
-		step = Tcl_UtfToUniChar(format, &ch);
+		step = TclUtfToUniChar(format, &ch);
 	    } else {
 		format += step;
-		step = Tcl_UtfToUniChar(format, &ch);
+		step = TclUtfToUniChar(format, &ch);
 	    }
 	} else if ((ch == 't') || (ch == 'z')) {
 	    format += step;
-	    step = Tcl_UtfToUniChar(format, &ch);
+	    step = TclUtfToUniChar(format, &ch);
 #ifndef TCL_WIDE_INT_IS_LONG
 	    if (sizeof(size_t) > sizeof(int)) {
 		useWide = 1;
@@ -1890,7 +1890,7 @@ Tcl_AppendFormatToObj(
 #endif
 	} else if ((ch == 'q') ||(ch == 'j')) {
 	    format += step;
-	    step = Tcl_UtfToUniChar(format, &ch);
+	    step = TclUtfToUniChar(format, &ch);
 #ifndef TCL_WIDE_INT_IS_LONG
 	    useWide = 1;
 #endif
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 859fe78..e651757 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -398,7 +398,7 @@ Tcl_UtfToUniCharDString(
 				 * appended to this previously initialized
 				 * DString. */
 {
-    Tcl_UniChar ch, *w, *wString;
+    Tcl_UniChar ch = 0, *w, *wString;
     const char *p, *end;
     int oldLength;
 
@@ -522,12 +522,12 @@ Tcl_NumUtfChars(
  *
  * Tcl_UtfFindFirst --
  *
- *	Returns a pointer to the first occurance of the given Tcl_UniChar in
+ *	Returns a pointer to the first occurance of the given character in
  *	the NULL-terminated UTF-8 string. The NULL terminator is considered
  *	part of the UTF-8 string. Equivalent to Plan 9 utfrune().
  *
  * Results:
- *	As above. If the Tcl_UniChar does not exist in the given string, the
+ *	As above. If the character does not exist in the given string, the
  *	return value is NULL.
  *
  * Side effects:
@@ -539,14 +539,21 @@ Tcl_NumUtfChars(
 const char *
 Tcl_UtfFindFirst(
     const char *src,		/* The UTF-8 string to be searched. */
-    int ch)			/* The Tcl_UniChar to search for. */
+    int ch)			/* The character to search for. */
 {
-    int len;
+    int len, fullchar;
     Tcl_UniChar find = 0;
 
     while (1) {
 	len = TclUtfToUniChar(src, &find);
-	if (find == ch) {
+	fullchar = find;
+#if TCL_UTF_MAX == 4
+	if (!len) {
+	    len += TclUtfToUniChar(stringPtr, &find);
+	    fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+#endif
+	if (find == fullchar) {
 	    return src;
 	}
 	if (*src == '\0') {
@@ -578,16 +585,23 @@ Tcl_UtfFindFirst(
 const char *
 Tcl_UtfFindLast(
     const char *src,		/* The UTF-8 string to be searched. */
-    int ch)			/* The Tcl_UniChar to search for. */
+    int ch)			/* The character to search for. */
 {
-    int len;
+    int len, fullchar;
     Tcl_UniChar find = 0;
     const char *last;
 
     last = NULL;
     while (1) {
 	len = TclUtfToUniChar(src, &find);
-	if (find == ch) {
+	fullchar = find;
+#if TCL_UTF_MAX == 4
+	if (!len) {
+	    len += TclUtfToUniChar(stringPtr, &find);
+	    fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+#endif
+	if (find == fullchar) {
 	    last = src;
 	}
 	if (*src == '\0') {
@@ -1158,7 +1172,7 @@ TclUtfCasecmp(
     const char *ct)		/* UTF string cs is compared to. */
 {
     while (*cs && *ct) {
-	Tcl_UniChar ch1, ch2;
+	Tcl_UniChar ch1 = 0, ch2 = 0;
 
 	cs += TclUtfToUniChar(cs, &ch1);
 	ct += TclUtfToUniChar(ct, &ch2);
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 8ebace5..21d1071 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1695,7 +1695,7 @@ TclTrimRight(
 	 */
 
 	do {
-	    Tcl_UniChar ch2;
+	    Tcl_UniChar ch2 = 0;
 	    int qInc = TclUtfToUniChar(q, &ch2);
 
 	    if (ch1 == ch2) {
@@ -1763,7 +1763,7 @@ TclTrimLeft(
      */
 
     do {
-	Tcl_UniChar ch1;
+	Tcl_UniChar ch1 = 0;
 	int pInc = TclUtfToUniChar(p, &ch1);
 	const char *q = trim;
 	int bytesLeft = numTrim;
@@ -1773,7 +1773,7 @@ TclTrimLeft(
 	 */
 
 	do {
-	    Tcl_UniChar ch2;
+	    Tcl_UniChar ch2 = 0;
 	    int qInc = TclUtfToUniChar(q, &ch2);
 
 	    if (ch1 == ch2) {
@@ -2107,7 +2107,7 @@ Tcl_StringCaseMatch(
 {
     int p, charLen;
     const char *pstart = pattern;
-    Tcl_UniChar ch1, ch2;
+    Tcl_UniChar ch1 = 0, ch2 = 0;
 
     while (1) {
 	p = *pattern;
@@ -2217,7 +2217,7 @@ Tcl_StringCaseMatch(
 	 */
 
 	if (p == '[') {
-	    Tcl_UniChar startChar, endChar;
+	    Tcl_UniChar startChar = 0, endChar = 0;
 
 	    pattern++;
 	    if (UCHAR(*str) < 0x80) {
@@ -2225,7 +2225,7 @@ Tcl_StringCaseMatch(
 			(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
 		str++;
 	    } else {
-		str += Tcl_UtfToUniChar(str, &ch1);
+		str += TclUtfToUniChar(str, &ch1);
 		if (nocase) {
 		    ch1 = Tcl_UniCharToLower(ch1);
 		}
@@ -2254,7 +2254,7 @@ Tcl_StringCaseMatch(
 				? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
 			pattern++;
 		    } else {
-			pattern += Tcl_UtfToUniChar(pattern, &endChar);
+			pattern += TclUtfToUniChar(pattern, &endChar);
 			if (nocase) {
 			    endChar = Tcl_UniCharToLower(endChar);
 			}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index ed1a8e5..894f431 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1738,15 +1738,15 @@ SerialSetOptionProc(
 	dcb.XonChar = argv[0][0];
 	dcb.XoffChar = argv[1][0];
 	if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
-	    Tcl_UniChar character;
+	    Tcl_UniChar character = 0;
 	    int charLen;
 
-	    charLen = Tcl_UtfToUniChar(argv[0], &character);
+	    charLen = TclUtfToUniChar(argv[0], &character);
 	    if (argv[0][charLen]) {
 		goto badXchar;
 	    }
 	    dcb.XonChar = (char) character;
-	    charLen = Tcl_UtfToUniChar(argv[1], &character);
+	    charLen = TclUtfToUniChar(argv[1], &character);
 	    if (argv[1][charLen]) {
 		goto badXchar;
 	    }
-- 
cgit v0.12


From 61536390c542d9aa9d1a91d173190cd2421294e5 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 20 Nov 2017 13:05:36 +0000
Subject: Fix executable flags

---
 generic/tclDecls.h    | 0
 generic/tclIntDecls.h | 0
 generic/tclStubInit.c | 0
 3 files changed, 0 insertions(+), 0 deletions(-)
 mode change 100755 => 100644 generic/tclDecls.h
 mode change 100755 => 100644 generic/tclIntDecls.h
 mode change 100755 => 100644 generic/tclStubInit.c

diff --git a/generic/tclDecls.h b/generic/tclDecls.h
old mode 100755
new mode 100644
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
old mode 100755
new mode 100644
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
old mode 100755
new mode 100644
-- 
cgit v0.12


From 3af16acbcb63ea2935d71b905371252560dc4659 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 29 Nov 2017 08:59:49 +0000
Subject: Treat invalid UTF-8 characters in the range 0x80-0x9F as cp1252: See
 [https://en.wikipedia.org/wiki/UTF-8]. To be added to TIP #389

---
 doc/Utf.3        |  3 +++
 generic/tclInt.h |  2 +-
 generic/tclUtf.c | 17 +++++++++++++++--
 3 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/doc/Utf.3 b/doc/Utf.3
index 638f349..de9545d 100644
--- a/doc/Utf.3
+++ b/doc/Utf.3
@@ -140,6 +140,9 @@ number of bytes read from \fIsrc\fR.  The caller must ensure that the
 source buffer is long enough such that this routine does not run off the
 end and dereference non-existent or random memory; if the source buffer
 is known to be null-terminated, this will not happen.  If the input is
+a byte in the range 0x80 - 0x9F, \fBTcl_UtfToUniChar\fR assumes the
+cp1252 encoding, stores the corresponding Tcl_UniChar in \fI*chPtr\fR
+and returns 1. If the input is otherwise
 not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first
 byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and
 0x00ff and return 1.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ef88bf5..d77889e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4446,7 +4446,7 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
  */
 
 #define TclUtfToUniChar(str, chPtr) \
-	((((unsigned char) *(str)) < 0xC0) ?		\
+	((((unsigned char) *(str)) < 0x80) ?		\
 	    ((*(chPtr) = (unsigned char) *(str)), 1)	\
 	    : Tcl_UtfToUniChar(str, chPtr))
 
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 4ed201f..aed332f 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -272,6 +272,13 @@ Tcl_UniCharToUtfDString(
  *---------------------------------------------------------------------------
  */
 
+static const unsigned short cp1252[32] = {
+  0x20ac,   0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
+  0x02C6, 0x2030, 0x0160, 0x2039, 0x0152,   0x8D, 0x017D,   0x8F,
+    0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
+   0x2DC, 0x2122, 0x0161, 0x203A, 0x0153,   0x9D, 0x017E, 0x0178
+};
+
 int
 Tcl_UtfToUniChar(
     register const char *src,	/* The UTF-8 string. */
@@ -288,11 +295,17 @@ Tcl_UtfToUniChar(
     if (byte < 0xC0) {
 	/*
 	 * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
-	 * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
+	 * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+	 * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+	 * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
 	 * characters representing themselves.
 	 */
 
-	*chPtr = (Tcl_UniChar) byte;
+	if ((unsigned)(byte-0x80) < (unsigned) 0x20) {
+	    *chPtr = (Tcl_UniChar) cp1252[byte-0x80];
+	} else {
+	    *chPtr = (Tcl_UniChar) byte;
+	}
 	return 1;
     } else if (byte < 0xE0) {
 	if ((src[1] & 0xC0) == 0x80) {
-- 
cgit v0.12


From 03c66864aa2ffa9871ce216b00cd661eaf1be688 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 29 Nov 2017 09:49:31 +0000
Subject: Fix [8e1e31eac0fd6b6c4452bc108a98ab08c6b64588|8e1e31eac0]: lsort
 treats NUL chars strangely

---
 generic/tclCmdIL.c |  4 +--
 generic/tclCmdMZ.c |  2 +-
 generic/tclInt.h   |  1 +
 generic/tclUtf.c   | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++---
 4 files changed, 80 insertions(+), 6 deletions(-)

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 47076ec..b41d312 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2945,7 +2945,7 @@ Tcl_LsearchObjCmd(
     double patDouble, objDouble;
     SortInfo sortInfo;
     Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
-    SortStrCmpFn_t strCmpFn = strcmp;
+    SortStrCmpFn_t strCmpFn = TclUtfCmp;
     Tcl_RegExp regexp = NULL;
     static const char *const options[] = {
 	"-all",	    "-ascii",   "-bisect", "-decreasing", "-dictionary",
@@ -4263,7 +4263,7 @@ SortCompare(
     int order = 0;
 
     if (infoPtr->sortMode == SORTMODE_ASCII) {
-	order = strcmp(elemPtr1->collationKey.strValuePtr,
+	order = TclUtfCmp(elemPtr1->collationKey.strValuePtr,
 		elemPtr2->collationKey.strValuePtr);
     } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
 	order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index ad1dd5f..a206cc5 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3547,7 +3547,7 @@ TclNRSwitchObjCmd(
 	OPT_LAST
     };
     typedef int (*strCmpFn_t)(const char *, const char *);
-    strCmpFn_t strCmpFn = strcmp;
+    strCmpFn_t strCmpFn = TclUtfCmp;
 
     mode = OPT_EXACT;
     foundmode = 0;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d77889e..ad1d9c6 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3219,6 +3219,7 @@ MODULE_SCOPE int	TclTrimLeft(const char *bytes, int numBytes,
 			    const char *trim, int numTrim);
 MODULE_SCOPE int	TclTrimRight(const char *bytes, int numBytes,
 			    const char *trim, int numTrim);
+MODULE_SCOPE int	TclUtfCmp(const char *cs, const char *ct);
 MODULE_SCOPE int	TclUtfCasecmp(const char *cs, const char *ct);
 MODULE_SCOPE int	TclUtfCount(int ch);
 MODULE_SCOPE Tcl_Obj *	TclpNativeToNormalized(ClientData clientData);
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index aed332f..aff10c1 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -1108,6 +1108,15 @@ Tcl_UtfNcmp(
 
 	cs += TclUtfToUniChar(cs, &ch1);
 	ct += TclUtfToUniChar(ct, &ch2);
+#if TCL_UTF_MAX == 4
+    /* map high surrogate characters to values > 0xffff */
+    if ((ch1 & 0xFC00) == 0xD800) {
+	ch1 += 0x4000;
+    }
+    if ((ch2 & 0xFC00) == 0xD800) {
+	ch2 += 0x4000;
+    }
+#endif
 	if (ch1 != ch2) {
 	    return (ch1 - ch2);
 	}
@@ -1140,6 +1149,7 @@ Tcl_UtfNcasecmp(
     unsigned long numChars)	/* Number of UTF chars to compare. */
 {
     Tcl_UniChar ch1 = 0, ch2 = 0;
+
     while (numChars-- > 0) {
 	/*
 	 * n must be interpreted as chars, not bytes.
@@ -1148,6 +1158,15 @@ Tcl_UtfNcasecmp(
 	 */
 	cs += TclUtfToUniChar(cs, &ch1);
 	ct += TclUtfToUniChar(ct, &ch2);
+#if TCL_UTF_MAX == 4
+    /* map high surrogate characters to values > 0xffff */
+    if ((ch1 & 0xFC00) == 0xD800) {
+	ch1 += 0x4000;
+    }
+    if ((ch2 & 0xFC00) == 0xD800) {
+	ch2 += 0x4000;
+    }
+#endif
 	if (ch1 != ch2) {
 	    ch1 = Tcl_UniCharToLower(ch1);
 	    ch2 = Tcl_UniCharToLower(ch2);
@@ -1158,11 +1177,56 @@ Tcl_UtfNcasecmp(
     }
     return 0;
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UtfCmp --
+ *
+ *	Compare UTF chars of string cs to string ct case sensitively.
+ *	Replacement for strcmp in Tcl core, in places where UTF-8 should
+ *	be handled.
+ *
+ * Results:
+ *	Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUtfCmp(
+    const char *cs,		/* UTF string to compare to ct. */
+    const char *ct)		/* UTF string cs is compared to. */
+{
+    Tcl_UniChar ch1 = 0, ch2 = 0;
+
+    while (*cs && *ct) {
+	cs += TclUtfToUniChar(cs, &ch1);
+	ct += TclUtfToUniChar(ct, &ch2);
+#if TCL_UTF_MAX == 4
+    /* map high surrogate characters to values > 0xffff */
+    if ((ch1 & 0xFC00) == 0xD800) {
+	ch1 += 0x4000;
+    }
+    if ((ch2 & 0xFC00) == 0xD800) {
+	ch2 += 0x4000;
+    }
+#endif
+	if (ch1 != ch2) {
+	    return ch1 - ch2;
+	}
+    }
+    return UCHAR(*cs) - UCHAR(*ct);
+}
+
 
 /*
  *----------------------------------------------------------------------
  *
- * Tcl_UtfNcasecmp --
+ * TclUtfCasecmp --
  *
  *	Compare UTF chars of string cs to string ct case insensitively.
  *	Replacement for strcasecmp in Tcl core, in places where UTF-8 should
@@ -1182,11 +1246,20 @@ TclUtfCasecmp(
     const char *cs,		/* UTF string to compare to ct. */
     const char *ct)		/* UTF string cs is compared to. */
 {
-    while (*cs && *ct) {
-	Tcl_UniChar ch1 = 0, ch2 = 0;
+    Tcl_UniChar ch1 = 0, ch2 = 0;
 
+    while (*cs && *ct) {
 	cs += TclUtfToUniChar(cs, &ch1);
 	ct += TclUtfToUniChar(ct, &ch2);
+#if TCL_UTF_MAX == 4
+    /* map high surrogate characters to values > 0xffff */
+    if ((ch1 & 0xFC00) == 0xD800) {
+	ch1 += 0x4000;
+    }
+    if ((ch2 & 0xFC00) == 0xD800) {
+	ch2 += 0x4000;
+    }
+#endif
 	if (ch1 != ch2) {
 	    ch1 = Tcl_UniCharToLower(ch1);
 	    ch2 = Tcl_UniCharToLower(ch2);
-- 
cgit v0.12


From 04d3db559246ee9e2ac2a5e20e52cf57b7af808b Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 10 Jan 2018 09:32:51 +0000
Subject: Don't use TclUtfToUniChar here: it doesn't give any advantage over
 Tcl_UtfToUniChar

---
 generic/tclUtil.c  | 4 ++--
 win/tclWinSerial.c | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 41795e8..15018de 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2223,7 +2223,7 @@ Tcl_StringCaseMatch(
 			(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
 		str++;
 	    } else {
-		str += TclUtfToUniChar(str, &ch1);
+		str += Tcl_UtfToUniChar(str, &ch1);
 		if (nocase) {
 		    ch1 = Tcl_UniCharToLower(ch1);
 		}
@@ -2252,7 +2252,7 @@ Tcl_StringCaseMatch(
 				? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
 			pattern++;
 		    } else {
-			pattern += TclUtfToUniChar(pattern, &endChar);
+			pattern += Tcl_UtfToUniChar(pattern, &endChar);
 			if (nocase) {
 			    endChar = Tcl_UniCharToLower(endChar);
 			}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 894f431..acfeecb 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1741,12 +1741,12 @@ SerialSetOptionProc(
 	    Tcl_UniChar character = 0;
 	    int charLen;
 
-	    charLen = TclUtfToUniChar(argv[0], &character);
+	    charLen = Tcl_UtfToUniChar(argv[0], &character);
 	    if (argv[0][charLen]) {
 		goto badXchar;
 	    }
 	    dcb.XonChar = (char) character;
-	    charLen = TclUtfToUniChar(argv[1], &character);
+	    charLen = Tcl_UtfToUniChar(argv[1], &character);
 	    if (argv[1][charLen]) {
 		goto badXchar;
 	    }
-- 
cgit v0.12


From eb3422673ff62a7427f2e6d166840fce68237d74 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 11 Jan 2018 14:11:38 +0000
Subject: Add test-cases for bug [11ae2be95dac9417], and make a start fixing
 it. Almost works.

---
 generic/tclCmdMZ.c     | 12 ++++++++++--
 generic/tclStringObj.c | 33 +++++++++++++++++++++++++++++++--
 tests/string.test      |  7 +++++++
 3 files changed, 48 insertions(+), 4 deletions(-)

diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index a206cc5..a23f007 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1435,7 +1435,7 @@ StringIndexCmd(
     }
 
     /*
-     * Get the char length to calulate what 'end' means.
+     * Get the char length to calculate what 'end' means.
      */
 
     length = Tcl_GetCharLength(objv[1]);
@@ -1444,7 +1444,15 @@ StringIndexCmd(
     }
 
     if ((index >= 0) && (index < length)) {
-	Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index);
+	int ch = Tcl_GetUniChar(objv[1], index);
+
+	if (ch >= 0x10000) {
+	    printf("HI: %x\n", ch);
+	}
+	if (ch == -1) {
+	    printf("LO: %x\n", ch);
+	    return TCL_OK;
+	}
 
 	/*
 	 * If we have a ByteArray object, we're careful to generate a new
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 01f8d80..aa5aba3 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -460,7 +460,8 @@ Tcl_GetCharLength(
  * Tcl_GetUniChar --
  *
  *	Get the index'th Unicode character from the String object. The index
- *	is assumed to be in the appropriate range.
+ *	is assumed to be in the appropriate range. If index references a lower
+ *	surrogate preceded by a higher surrogate, the result = -1;
  *
  * Results:
  *	Returns the index'th Unicode character in the Object.
@@ -478,6 +479,7 @@ Tcl_GetUniChar(
     int index)			/* Get the index'th Unicode character. */
 {
     String *stringPtr;
+    int ch;
 
     /*
      * Optimize the case where we're really dealing with a bytearray object
@@ -512,7 +514,23 @@ Tcl_GetUniChar(
 	FillUnicodeRep(objPtr);
 	stringPtr = GET_STRING(objPtr);
     }
-    return (int) stringPtr->unicode[index];
+
+	ch = stringPtr->unicode[index];
+#if TCL_UTF_MAX == 4
+	/* See: bug [11ae2be95dac9417] */
+	if ((ch&0xF800) == 0xD800) {
+	    if (ch&0x400) {
+		if ((index > 0) && ((stringPtr->unicode[index-1]&0xFC00) == 0xD800)) {
+		    ch = -1; /* low surrogate preceded by high surrogate */
+		}
+	    } else if ((++index < stringPtr->numChars)
+		    && ((stringPtr->unicode[index]&0xFC00) == 0xDC00)) {
+		/* high surrogate followed by low surrogate */
+		ch = (((ch & 0x3FF) << 10) | (stringPtr->unicode[index] & 0x3FF)) + 0x10000;
+	    }
+	}
+#endif
+    return ch;
 }
 
 /*
@@ -656,6 +674,17 @@ Tcl_GetRange(
 	stringPtr = GET_STRING(objPtr);
     }
 
+#if TCL_UTF_MAX == 4
+	/* See: bug [11ae2be95dac9417] */
+	if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00)
+		&& ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) {
+	    ++first;
+	}
+	if ((last+1<stringPtr->numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00)
+		&& ((stringPtr->unicode[last]&0xFC00) == 0xD800)) {
+	    ++last;
+	}
+#endif
     return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1);
 }
 
diff --git a/tests/string.test b/tests/string.test
index cebaf4c..58328bb 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -24,6 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
 
 testConstraint testobj [expr {[info commands testobj] != {}}]
 testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
+testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
 
 # Used for constraining memory leak tests
 testConstraint memory [llength [info commands memory]]
@@ -302,6 +303,9 @@ test string-5.19 {string index, bytearray object out of bounds} {
 test string-5.20 {string index, bytearray object out of bounds} {
     string index [binary format I* {0x50515253 0x52}] 20
 } {}
+test string-5.21 {string index, surrogates, bug [11ae2be95dac9417]} fullutf {
+    list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]
+} [list \U100000 {} b]
 
 
 proc largest_int {} {
@@ -1288,6 +1292,9 @@ test string-12.22 {string range, shimmering binary/index} {
     binary scan $s a* x
     string range $s $s end
 } 000000001
+test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf {
+    list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]
+} [list \U100000 {} b]
 
 test string-13.1 {string repeat} {
     list [catch {string repeat} msg] $msg
-- 
cgit v0.12


From c8219a9a2995c5658cd709f4bb7b5b933e6575e9 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 12 Jan 2018 10:03:58 +0000
Subject: Fix [11ae2be95d]: tip-389 branch: string range errors with code
 points greater than U+FFFF

---
 generic/tclExecute.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f2cda0c..63281a8 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5445,7 +5445,7 @@ TEBCresume(
 		    valuePtr->bytes+index, 1);
 	} else {
 	    char buf[TCL_UTF_MAX];
-	    Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index);
+	    int ch = Tcl_GetUniChar(valuePtr, index);
 
 	    /*
 	     * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
@@ -5453,7 +5453,7 @@ TEBCresume(
 	     * practical use.
 	     */
 
-	    length = Tcl_UniCharToUtf(ch, buf);
+	    length = (ch != -1) ? Tcl_UniCharToUtf(ch, buf) : 0;
 	    objResultPtr = Tcl_NewStringObj(buf, length);
 	}
 
-- 
cgit v0.12


From 77d58c599368d5ecbe0803d79023efe7cd2f24bc Mon Sep 17 00:00:00 2001
From: bll <brad.lanam.comp@gmail.com>
Date: Tue, 6 Mar 2018 17:19:40 +0000
Subject: tip-421: array for:   a) Fix bug starting search (name not set).   b)
 Fix error message for array change on iteration.

---
 generic/tclVar.c | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index da9fb23..c5df6c8 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3074,6 +3074,8 @@ ArrayObjFirst(
     Tcl_HashEntry   *hPtr;
     int             isNew;
 
+    /* this code is duplicated from arraystartsearchcmd,
+       excepting that arrayNameObj is set */
     searchPtr->varPtr = varPtr;
     searchPtr->arrayNameObj = arrayNameObj;
 
@@ -3090,6 +3092,7 @@ ArrayObjFirst(
     searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
 	    &searchPtr->search);
     Tcl_SetHashValue(hPtr, searchPtr);
+    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(arrayNameObj));
 }
 
 int
@@ -3307,8 +3310,10 @@ ArrayForLoopCallback(
     if (done != TCL_CONTINUE) {
 	Tcl_ResetResult(interp);
         if (done == TCL_ERROR) {
-          varPtr->flags |= TCL_LEAVE_ERR_MSG;
-          Tcl_AddErrorInfo(interp, "array changed during iteration");
+	  Tcl_SetObjResult(interp, Tcl_NewStringObj(
+	      "array changed during iteration", -1));
+	  Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
+	  varPtr->flags |= TCL_LEAVE_ERR_MSG;
           result = done;
         }
 	goto arrayfordone;
-- 
cgit v0.12


From d2d193de11dddfa68c52223bfee22fc1c7e9de3c Mon Sep 17 00:00:00 2001
From: bll <brad.lanam.comp@gmail.com>
Date: Tue, 6 Mar 2018 18:21:34 +0000
Subject: array for: updated documentation: value variable is not optional, add
 specifics about when array for terminates.

---
 doc/array.n | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/doc/array.n b/doc/array.n
index 751c688..d6d4dff 100644
--- a/doc/array.n
+++ b/doc/array.n
@@ -47,12 +47,14 @@ been the return value from a previous invocation of
 Returns 1 if \fIarrayName\fR is an array variable, 0 if there
 is no variable by that name or if it is a scalar variable.
 .TP
-\fBarray for {\fIkeyVariable ?valueVariable?\fB} \fIarrayName body\fR
-The first argument is a one or two element list of variable names for the
+\fBarray for {\fIkeyVariable valueVariable\fB} \fIarrayName body\fP
+The first argument is a two element list of variable names for the
 key and value of each entry in the array.  The second argument is the
 array name to iterate over.  The third argument is the body to execute
 for each key and value returned.
 The ordering of the returned keys is undefined.
+If an array element is deleted or a new array element is inserted during
+the \fIarray for\fP process, the command will terminate with an error.
 .TP
 \fBarray get \fIarrayName\fR ?\fIpattern\fR?
 Returns a list containing pairs of elements.  The first
-- 
cgit v0.12


From a735b5d3acb8dadac8bfec4f9b06cb2b1063db2d Mon Sep 17 00:00:00 2001
From: bll <brad.lanam.comp@gmail.com>
Date: Tue, 6 Mar 2018 18:42:25 +0000
Subject: array for:   Add missing ObjCmdProc wrapper around the NR proc.

---
 generic/tclVar.c | 16 +++++++++++++++-
 1 file changed, 15 insertions(+), 1 deletion(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index c5df6c8..8986fdd 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -177,6 +177,7 @@ static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
 			    Tcl_Obj *patternPtr, int includeLinks);
 static void             ArrayDoneSearch (Interp *iPtr, Var *varPtr, ArraySearch *searchPtr);
 static Tcl_NRPostProc   ArrayForLoopCallback;
+static int              ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
 static void		DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
 static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
 			    Var *varPtr, int flags, int index);
@@ -3039,6 +3040,7 @@ TclArraySet(
 /*
  *----------------------------------------------------------------------
  *
+ * ArrayForObjCmd
  * ArrayForNRCmd
  * ArrayForLoopCallback
  * ArrayObjFirst
@@ -3049,6 +3051,8 @@ TclArraySet(
  *  The array for command iterates over the array, setting the
  *  the specified loop variables, and executing the body each iteration.
  *
+ *  ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd().
+ *
  *  ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
  *  inside the structure and calls VarHashFirstEntry to start the hash
  *  iteration.
@@ -3152,6 +3156,16 @@ ArrayObjNext(
     return donerc;
 }
 
+int
+ArrayForObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv);
+}
+
 static int
 ArrayForNRCmd(
     ClientData dummy,
@@ -4577,7 +4591,7 @@ TclInitArrayCmd(
 	{"anymore",	ArrayAnyMoreCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
 	{"donesearch",	ArrayDoneSearchCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
 	{"exists",	ArrayExistsCmd,		TclCompileArrayExistsCmd, NULL, NULL, 0},
-	{"for",		NULL,			TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
+	{"for",		ArrayForObjCmd,		TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
 	{"get",		ArrayGetCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
 	{"names",	ArrayNamesCmd,		TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
 	{"nextelement",	ArrayNextElementCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
-- 
cgit v0.12


From 2d5be386031bb7171009c07d78243bfcb1642d7d Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 16 Apr 2018 14:15:22 +0000
Subject: Memleak fix from Brad Lanam.

---
 generic/tclVar.c | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index 8986fdd..92b3524 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3097,6 +3097,7 @@ ArrayObjFirst(
 	    &searchPtr->search);
     Tcl_SetHashValue(hPtr, searchPtr);
     searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(arrayNameObj));
+    Tcl_IncrRefCount(searchPtr->name);
 }
 
 int
@@ -3361,6 +3362,7 @@ ArrayForLoopCallback(
      */
     if (done != TCL_ERROR) {
       ArrayDoneSearch (iPtr, varPtr, searchPtr);
+	Tcl_DecrRefCount(searchPtr->name);
       ckfree(searchPtr);
     }
 
-- 
cgit v0.12


From 08d704bbb1b78da3ca7806bfc5c7fd8fae51e570 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2018 03:48:47 +0000
Subject: Test of shimmer segfault.

---
 tests/var.test | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/tests/var.test b/tests/var.test
index a391a01..6ac3e52 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -1143,6 +1143,15 @@ test var-23.13 {array enumeration, number of traces} -setup {
     unset -nocomplain ::a
     unset -nocomplain reslist
 } -result 3
+test var-23.14 {array for, shared arguments} -setup {
+    set vn {k v}
+    unset -nocomplain $vn
+} -body {
+    array set $vn {a 1 b 2 c 3}
+    array for $vn $vn {}
+} -cleanup {
+    unset -nocomplain $vn vn
+} -result {}
 
 catch {namespace delete ns}
 catch {unset arr}
-- 
cgit v0.12


From 47fc4afd862da2e3956e8437f7689ba043ac3a43 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2018 11:11:35 +0000
Subject: Satisfy test var-23.14

---
 generic/tclVar.c | 42 ++++++++++++++++++++----------------------
 1 file changed, 20 insertions(+), 22 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index 92b3524..a2fa680 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3175,13 +3175,11 @@ ArrayForNRCmd(
     Tcl_Obj *const *objv)
 {
     Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
-    Tcl_Obj **varv;
-    Tcl_Obj *arrayNameObj;
+    Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
     ArraySearch *searchPtr = NULL;
     Var *varPtr;
     Var *arrayPtr;
-    int varc;
+    int numVars;
 
     /*
      * array for {k v} a body
@@ -3197,10 +3195,12 @@ ArrayForNRCmd(
      * Parse arguments.
      */
 
-    if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+
+    if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if (varc != 2) {
+
+    if (numVars != 2) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"must have two variable names", -1));
 	Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
@@ -3208,9 +3208,6 @@ ArrayForNRCmd(
     }
 
     arrayNameObj = objv[2];
-    keyVarObj = varv[0];
-    valueVarObj = varv[1];
-    scriptObj = objv[3];
 
     /*
      * Locate the array variable.
@@ -3262,16 +3259,16 @@ ArrayForNRCmd(
      * loop) don't vanish.
      */
 
-    Tcl_IncrRefCount(keyVarObj);
-    Tcl_IncrRefCount(valueVarObj);
+    varListObj = TclListObjCopy(NULL, objv[1]);
+    scriptObj = objv[3];
     Tcl_IncrRefCount(scriptObj);
 
     /*
      * Run the script.
      */
 
-    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, keyVarObj,
-	    valueVarObj, scriptObj);
+    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
+	    NULL, scriptObj);
     return TCL_OK;
 }
 
@@ -3283,13 +3280,13 @@ ArrayForLoopCallback(
 {
     Interp *iPtr = (Interp *) interp;
     ArraySearch *searchPtr = data[0];
-    Tcl_Obj *keyVarObj = data[1];
-    Tcl_Obj *valueVarObj = data[2];
+    Tcl_Obj *varListObj = data[1];
     Tcl_Obj *scriptObj = data[3];
+    Tcl_Obj **varv;
     Tcl_Obj *keyObj, *valueObj;
     Var *varPtr;
     Var *arrayPtr;
-    int done;
+    int done, varc;
 
     /*
      * Process the result from the previous execution of the script body.
@@ -3333,12 +3330,14 @@ ArrayForLoopCallback(
         }
 	goto arrayfordone;
     }
-    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
+
+    Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv);
+    if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
       result = TCL_ERROR;
       goto arrayfordone;
     }
     if (valueObj != NULL) {
-      if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
+      if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
         result = TCL_ERROR;
         goto arrayfordone;
       }
@@ -3348,8 +3347,8 @@ ArrayForLoopCallback(
      * Run the script.
      */
 
-    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, keyVarObj,
-	    valueVarObj, scriptObj);
+    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
+	    NULL, scriptObj);
     return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
 
     /*
@@ -3366,8 +3365,7 @@ ArrayForLoopCallback(
       ckfree(searchPtr);
     }
 
-    TclDecrRefCount(keyVarObj);
-    TclDecrRefCount(valueVarObj);
+    TclDecrRefCount(varListObj);
     TclDecrRefCount(scriptObj);
     return result;
 }
-- 
cgit v0.12


From 80e5aed49e2cac237b9d91db0f5dc1139c6462dd Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2018 14:32:30 +0000
Subject: Restore build success to the TCL_REMOVE_OBSOLETE_TRACES
 configuration.

---
 generic/tclTrace.c | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 2e1b241..cb465ca 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -176,7 +176,9 @@ Tcl_TraceObjCmd(
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
     int optionIndex;
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
     char *name, *flagOps, *p;
+#endif
     /* Main sub commands to 'trace' */
     static const char *traceOptions[] = {
 	"add", "info", "remove",
@@ -352,10 +354,12 @@ Tcl_TraceObjCmd(
     }
     return TCL_OK;
 
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
   badVarOps:
     Tcl_AppendResult(interp, "bad operations \"", flagOps,
 	    "\": should be one or more of rwua", NULL);
     return TCL_ERROR;
+#endif
 }
 
 /*
@@ -902,9 +906,11 @@ TraceVariableObjCmd(
 		    (sizeof(CombinedTraceVarInfo) + length + 1
 		    - sizeof(ctvarPtr->traceCmdInfo.command)));
 	    ctvarPtr->traceCmdInfo.flags = flags;
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
 	    if (objv[0] == NULL) {
 		ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
 	    }
+#endif
 	    ctvarPtr->traceCmdInfo.length = length;
 	    flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
 	    memcpy(ctvarPtr->traceCmdInfo.command, command, length+1);
@@ -931,7 +937,11 @@ TraceVariableObjCmd(
 		    TraceVarProc, clientData)) != 0) {
 		tvarPtr = (TraceVarInfo *) clientData;
 		if ((tvarPtr->length == length)
-			&& ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
+			&& ((tvarPtr->flags
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+& ~TCL_TRACE_OLD_STYLE
+#endif
+						)==flags)
 			&& (strncmp(command, tvarPtr->command,
 				(size_t) length) == 0)) {
 		    Tcl_UntraceVar2(interp, name, NULL,
-- 
cgit v0.12


From f316d7539c5bb69dc519fc27be251c9ba056c189 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2018 18:34:41 +0000
Subject: [array set] must fire array traces. Don't disrupt that by reporting
 argument errors too early.

---
 generic/tclCompCmds.c | 11 +++++++++++
 tests/var.test        |  9 +++++++++
 2 files changed, 20 insertions(+)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c2b4bdb..9a15ee0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -322,11 +322,22 @@ TclCompileArraySetCmd(
      */
 
     if (isDataValid && !isDataEven) {
+	/* Abandon compile and let direct eval raise the error */
+	code = TCL_ERROR;
+	goto done;
+
+	/*
+	 * We used to compile to the bytecode that would throw the error,
+	 * but that was wrong because it would not invoke the array trace
+	 * on the variable.
+	 *
 	PushStringLiteral(envPtr, "list must have an even number of elements");
 	PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
 	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
 	TclEmitInt4(		0,				envPtr);
 	goto done;
+	 *
+	 */
     }
 
     /*
diff --git a/tests/var.test b/tests/var.test
index a9d93ac..d1340f6 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -930,6 +930,15 @@ test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup {
 test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
     apply {{} {set name foo(bar); array set $name {a 1}}}
 } -returnCodes error -match glob -result *
+test var-20.11 {array set don't compile bad initializer} -setup {
+    unset -nocomplain foo
+    trace add variable foo array {set foo(bar) baz;#}
+} -body {
+    catch {array set foo bad}
+    set foo(bar)
+} -cleanup {
+    unset -nocomplain foo
+} -result baz
 
 test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
     proc linenumber {} {dict get [info frame -1] line}
-- 
cgit v0.12


From 5dff80f2fe38009bc7e7c6b3f74033a8a05a59a1 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2018 18:54:36 +0000
Subject: Gentler fallback.

---
 generic/tclCompCmds.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 9a15ee0..22bbca0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -322,8 +322,8 @@ TclCompileArraySetCmd(
      */
 
     if (isDataValid && !isDataEven) {
-	/* Abandon compile and let direct eval raise the error */
-	code = TCL_ERROR;
+	/* Abandon custom compile and let invocation raise the error */
+	code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 	goto done;
 
 	/*
-- 
cgit v0.12


From 62ea5e49a10037bf3a3896a933db4951ff0b15bc Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2018 19:14:01 +0000
Subject: Array trace firing must come before argument checking might raise
 error.

---
 generic/tclCompCmds.c |  7 ++++---
 tests/var.test        | 13 +++++++++++++
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 22bbca0..838e9d7 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -415,6 +415,10 @@ TclCompileArraySetCmd(
      * Start issuing instructions to write to the array.
      */
 
+    TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
+    TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
+    TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
+
     CompileWord(envPtr, dataTokenPtr, interp, 2);
     if (!isDataLiteral || !isDataValid) {
 	/*
@@ -439,9 +443,6 @@ TclCompileArraySetCmd(
 	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
     }
 
-    TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
-    TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
-    TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
     TclEmitInstInt4(INST_FOREACH_START, infoIndex,	envPtr);
     offsetBack = CurrentOffset(envPtr);
     Emit14Inst(	INST_LOAD_SCALAR, keyVar,		envPtr);
diff --git a/tests/var.test b/tests/var.test
index d1340f6..01080bc 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -939,6 +939,19 @@ test var-20.11 {array set don't compile bad initializer} -setup {
 } -cleanup {
     unset -nocomplain foo
 } -result baz
+test var-20.12 {array set don't compile bad initializer} -setup {
+    unset -nocomplain ::foo
+    trace add variable ::foo array {set ::foo(bar) baz;#}
+} -body {
+    catch {apply {{} {
+	set value bad
+	array set ::foo $value
+
+    }}}
+    set ::foo(bar)
+} -cleanup {
+    unset -nocomplain ::foo
+} -result baz
 
 test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
     proc linenumber {} {dict get [info frame -1] line}
-- 
cgit v0.12


From 6b8039a9524bb88679e0d837a5345f26c8654a52 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2018 20:29:02 +0000
Subject: Refactor array trace handling into a common routine
 TclCheckArrayTraces().

---
 generic/tclExecute.c |  17 ++---
 generic/tclInt.h     |   2 +
 generic/tclTrace.c   |  41 ++++++++++++
 generic/tclVar.c     | 180 +++++++++++----------------------------------------
 4 files changed, 86 insertions(+), 154 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index aab9092..5bc5c2d 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4294,17 +4294,12 @@ TEBCresume(
 	varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
 		/*createPart1*/0, /*createPart2*/0, &arrayPtr);
     doArrayExists:
-	if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-		&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	    DECACHE_STACK_INFO();
-	    result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,
-		    NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|
-		    TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd);
-	    CACHE_STACK_INFO();
-	    if (result == TCL_ERROR) {
-		TRACE_ERROR(interp);
-		goto gotError;
-	    }
+	DECACHE_STACK_INFO();
+	result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd);
+	CACHE_STACK_INFO();
+	if (result == TCL_ERROR) {
+	    TRACE_ERROR(interp);
+	    goto gotError;
 	}
 	if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
 	    objResultPtr = TCONST(1);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index dc7909c..371e3fa 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2873,6 +2873,8 @@ MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
 MODULE_SCOPE double	TclCeil(const mp_int *a);
 MODULE_SCOPE void	TclChannelPreserve(Tcl_Channel chan);
 MODULE_SCOPE void	TclChannelRelease(Tcl_Channel chan);
+MODULE_SCOPE int	TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
+			    Var *arrayPtr, Tcl_Obj *name, int index);
 MODULE_SCOPE int	TclCheckBadOctal(Tcl_Interp *interp,
 			    const char *value);
 MODULE_SCOPE int	TclChanCaughtErrorBypass(Tcl_Interp *interp,
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 958399a..d48761b 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -2478,6 +2478,47 @@ TclVarTraceExists(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCheckArrayTraces --
+ *
+ *	This function is invoked to when we operate on an array variable,
+ *	to allow any array traces to fire.
+ *
+ * Results:
+ *	Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if
+ *	invocation of a trace function indicated an error. When TCL_ERROR is
+ *	returned, then error information is left in interp.
+ *
+ * Side effects:
+ *	Almost anything can happen, depending on trace; this function itself
+ *	doesn't have any side effects.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCheckArrayTraces(
+    Tcl_Interp *interp,
+    Var *varPtr,
+    Var *arrayPtr,
+    Tcl_Obj *name,
+    int index)
+{
+    int code = TCL_OK;
+
+    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+	&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+	Interp *iPtr = (Interp *)interp;
+
+	code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL,
+		(TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY),
+		/* leaveErrMsg */ 1, index);
+    }
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCallVarTraces --
  *
  *	This function is invoked to find and invoke relevant trace functions
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 3dd6790..e07d39a 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3121,7 +3121,7 @@ ArrayStartSearchCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
+    Interp *iPtr = (Interp *)interp;
     Var *varPtr, *arrayPtr;
     Tcl_HashEntry *hPtr;
     Tcl_Obj *varNameObj;
@@ -3143,18 +3143,9 @@ ArrayStartSearchCmd(
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
     varName = TclGetString(varNameObj);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -3219,7 +3210,7 @@ ArrayAnyMoreCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
+    Interp *iPtr = (Interp *)interp;
     Var *varPtr, *arrayPtr;
     Tcl_Obj *varNameObj, *searchObj;
     int gotValue;
@@ -3239,18 +3230,9 @@ ArrayAnyMoreCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -3326,7 +3308,6 @@ ArrayNextElementCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr;
     Tcl_Obj *varNameObj, *searchObj;
     ArraySearch *searchPtr;
@@ -3345,18 +3326,9 @@ ArrayNextElementCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -3435,7 +3407,7 @@ ArrayDoneSearchCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
+    Interp *iPtr = (Interp *)interp;
     Var *varPtr, *arrayPtr;
     Tcl_HashEntry *hPtr;
     Tcl_Obj *varNameObj, *searchObj;
@@ -3455,18 +3427,9 @@ ArrayDoneSearchCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -3543,7 +3506,7 @@ ArrayExistsCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
+    Interp *iPtr = (Interp *)interp;
     Var *varPtr, *arrayPtr;
     Tcl_Obj *arrayNameObj;
     int notArray;
@@ -3561,18 +3524,9 @@ ArrayExistsCmd(
     varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, arrayNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -3610,7 +3564,6 @@ ArrayGetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr, *varPtr2;
     Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
     Tcl_Obj **nameObjPtr, *patternObj;
@@ -3639,18 +3592,9 @@ ArrayGetCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -3798,7 +3742,6 @@ ArrayNamesCmd(
 	"-exact", "-glob", "-regexp", NULL
     };
     enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr, *varPtr2;
     Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj;
     Tcl_HashSearch search;
@@ -3819,18 +3762,9 @@ ArrayNamesCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -3986,7 +3920,6 @@ ArraySetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr;
 
     if (objc != 3) {
@@ -4001,18 +3934,9 @@ ArraySetCmd(
     varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, objv[1], -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     return TclArraySet(interp, objv[1], objv[2]);
@@ -4043,7 +3967,6 @@ ArraySizeCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr;
     Tcl_Obj *varNameObj;
     Tcl_HashSearch search;
@@ -4063,18 +3986,9 @@ ArraySizeCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -4127,7 +4041,6 @@ ArrayStatsCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr;
     Tcl_Obj *varNameObj;
     char *stats;
@@ -4145,18 +4058,9 @@ ArrayStatsCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
@@ -4210,7 +4114,6 @@ ArrayUnsetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr;
     Tcl_Obj *varNameObj, *patternObj, *nameObj;
     Tcl_HashSearch search;
@@ -4238,18 +4141,9 @@ ArrayUnsetCmd(
     varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
+	    == TCL_ERROR) {
+	return TCL_ERROR;
     }
 
     /*
-- 
cgit v0.12


From 28ac08663306381af8f310b247bec60e5ed694db Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 17 Apr 2018 21:49:00 +0000
Subject: Slightly better unmatched-surrogates handling. Unmatched High
 surrogates will still be silently removed, but Unmatched Low surrogates will
 pass through as-is now. Inspired by Kevin Kenny's remarks. Thanks!

---
 generic/tclUtf.c | 19 +++++++++++++------
 1 file changed, 13 insertions(+), 6 deletions(-)

diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 923b1f8..ab4e142 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -148,15 +148,22 @@ Tcl_UniCharToUtf(
 	    if ((ch & 0xF800) == 0xD800) {
 		if (ch & 0x0400) {
 		    /* Low surrogate */
-		    buf[3] = (char) ((ch | 0x80) & 0xBF);
-		    buf[2] |= (char) (((ch >> 6) | 0x80) & 0x8F);
-		    return 4;
+		    if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80)
+			    && ((buf[2] & 0xCF) == 0)) {
+			/* Previous Tcl_UniChar was a High surrogate, so combine */
+			buf[3] = (char) ((ch & 0x3F) | 0x80);
+			buf[2] |= (char) (((ch >> 6) & 0x0F) | 0x80);
+			return 4;
+		    }
+		    /* Previous Tcl_UniChar was not a High surrogate, so just output */
 		} else {
 		    /* High surrogate */
 		    ch += 0x40;
-		    buf[2] = (char) (((ch << 4) | 0x80) & 0xB0);
-		    buf[1] = (char) (((ch >> 2) | 0x80) & 0xBF);
-		    buf[0] = (char) (((ch >> 8) | 0xF0) & 0xF7);
+		    /* Fill buffer with specific 3-byte (invalid) byte combination,
+		       so following Low surrogate can recognize it and combine */
+		    buf[2] = (char) ((ch << 4) & 0x30);
+		    buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80);
+		    buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0);
 		    return 0;
 		}
 	    }
-- 
cgit v0.12


From 327595170bbc91997186ac34d44238537e330cd5 Mon Sep 17 00:00:00 2001
From: oehhar <harald.oehlmann@elmicron.de>
Date: Wed, 18 Apr 2018 11:59:57 +0000
Subject: http::geturl now returns full error stack information if the initial
 socket command fails Ticket [ff82755e15]

---
 library/http/http.tcl     | 7 ++++---
 library/http/pkgIndex.tcl | 2 +-
 unix/Makefile.in          | 4 ++--
 win/Makefile.in           | 4 ++--
 4 files changed, 9 insertions(+), 8 deletions(-)

diff --git a/library/http/http.tcl b/library/http/http.tcl
index 9f5310b..186d067 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
 package require Tcl 8.6-
 # Keep this in sync with pkgIndex.tcl and with the install directories in
 # Makefiles
-package provide http 2.8.12
+package provide http 2.8.13
 
 namespace eval http {
     # Allow resourcing to not clobber existing data
@@ -602,7 +602,7 @@ proc http::geturl {url args} {
 	if {[info exists state(-myaddr)]} {
 	    lappend sockopts -myaddr $state(-myaddr)
 	}
-        if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
+        if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} {
 	    # something went wrong while trying to establish the connection.
 	    # Clean up after events and such, but DON'T call the command
 	    # callback (if available) because we're going to throw an
@@ -611,7 +611,8 @@ proc http::geturl {url args} {
 	    set state(sock) $sock
 	    Finish $token "" 1
 	    cleanup $token
-	    return -code error $sock
+	    dict unset errdict -level
+	    return -options $errdict $sock
         }
     }
     set state(sock) $sock
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index d3fc7af..3324af9 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,2 @@
 if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
-package ifneeded http 2.8.12 [list tclPkgSetup $dir http 2.8.12 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.8.13 [list tclPkgSetup $dir http 2.8.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 29c051d..4277fad 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -840,8 +840,8 @@ install-libraries: libraries
 	    do \
 	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \
 	    done;
-	@echo "Installing package http 2.8.12 as a Tcl Module";
-	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm;
+	@echo "Installing package http 2.8.13 as a Tcl Module";
+	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.13.tm;
 	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
 	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
 	    do \
diff --git a/win/Makefile.in b/win/Makefile.in
index 633a9f5..f063da1 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -651,8 +651,8 @@ install-libraries: libraries install-tzdata install-msgs
 	    do \
 	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
 	    done;
-	@echo "Installing package http 2.8.12 as a Tcl Module";
-	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm;
+	@echo "Installing package http 2.8.13 as a Tcl Module";
+	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.13.tm;
 	@echo "Installing library opt0.4 directory";
 	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
 	    do \
-- 
cgit v0.12


From fb91d4b68b081abb8ff689ed624a567c1a27a260 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 18 Apr 2018 19:21:33 +0000
Subject: Refactor the common operations of looking up and checking traces on
 an array variable into a single routine LocateArray().

---
 generic/tclVar.c | 152 +++++++++++++++----------------------------------------
 1 file changed, 41 insertions(+), 111 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index e07d39a..a4cd62b 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -176,6 +176,8 @@ static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
 static void		DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
 static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
 			    Var *varPtr, int flags, int index);
+static int		LocateArray(Tcl_Interp *interp, Tcl_Obj *name,
+			    Var **varPtrPtr);
 static Tcl_Var		ObjFindNamespaceVar(Tcl_Interp *interp,
 			    Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr,
 			    int flags);
@@ -269,6 +271,22 @@ TclVarHashCreateVar(
 
     return varPtr;
 }
+
+static int
+LocateArray(
+    Tcl_Interp *interp,
+    Tcl_Obj *name,
+    Var **varPtrPtr)
+{
+    Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0,
+	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+    *varPtrPtr = varPtr;
+    return TCL_OK;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -3122,7 +3140,7 @@ ArrayStartSearchCmd(
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *)interp;
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
     Tcl_HashEntry *hPtr;
     Tcl_Obj *varNameObj;
     int isNew;
@@ -3135,16 +3153,7 @@ ArrayStartSearchCmd(
     }
     varNameObj = objv[1];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-    varName = TclGetString(varNameObj);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3154,6 +3163,7 @@ ArrayStartSearchCmd(
      * traces.
      */
 
+    varName = TclGetString(varNameObj);
     if ((varPtr == NULL) || !TclIsVarArray(varPtr)
 	    || TclIsVarUndefined(varPtr)) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3211,7 +3221,7 @@ ArrayAnyMoreCmd(
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *)interp;
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
     Tcl_Obj *varNameObj, *searchObj;
     int gotValue;
     ArraySearch *searchPtr;
@@ -3223,15 +3233,7 @@ ArrayAnyMoreCmd(
     varNameObj = objv[1];
     searchObj = objv[2];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3308,7 +3310,7 @@ ArrayNextElementCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
     Tcl_Obj *varNameObj, *searchObj;
     ArraySearch *searchPtr;
 
@@ -3319,15 +3321,7 @@ ArrayNextElementCmd(
     varNameObj = objv[1];
     searchObj = objv[2];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3408,7 +3402,7 @@ ArrayDoneSearchCmd(
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *)interp;
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
     Tcl_HashEntry *hPtr;
     Tcl_Obj *varNameObj, *searchObj;
     ArraySearch *searchPtr, *prevPtr;
@@ -3420,15 +3414,7 @@ ArrayDoneSearchCmd(
     varNameObj = objv[1];
     searchObj = objv[2];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3507,7 +3493,7 @@ ArrayExistsCmd(
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *)interp;
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
     Tcl_Obj *arrayNameObj;
     int notArray;
 
@@ -3517,15 +3503,7 @@ ArrayExistsCmd(
     }
     arrayNameObj = objv[1];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, arrayNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3564,7 +3542,7 @@ ArrayGetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Var *varPtr, *arrayPtr, *varPtr2;
+    Var *varPtr, *varPtr2;
     Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
     Tcl_Obj **nameObjPtr, *patternObj;
     Tcl_HashSearch search;
@@ -3585,15 +3563,7 @@ ArrayGetCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3742,7 +3712,7 @@ ArrayNamesCmd(
 	"-exact", "-glob", "-regexp", NULL
     };
     enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
-    Var *varPtr, *arrayPtr, *varPtr2;
+    Var *varPtr, *varPtr2;
     Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj;
     Tcl_HashSearch search;
     const char *pattern = NULL;
@@ -3755,15 +3725,7 @@ ArrayNamesCmd(
     varNameObj = objv[1];
     patternObj = (objc > 2 ? objv[objc-1] : NULL);
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3920,22 +3882,14 @@ ArraySetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
 
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
 	return TCL_ERROR;
     }
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, objv[1], -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3967,7 +3921,7 @@ ArraySizeCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
     Tcl_Obj *varNameObj;
     Tcl_HashSearch search;
     Var *varPtr2;
@@ -3979,15 +3933,7 @@ ArraySizeCmd(
     }
     varNameObj = objv[1];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -4041,7 +3987,7 @@ ArrayStatsCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Var *varPtr, *arrayPtr;
+    Var *varPtr;
     Tcl_Obj *varNameObj;
     char *stats;
 
@@ -4051,15 +3997,7 @@ ArrayStatsCmd(
     }
     varNameObj = objv[1];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -4114,7 +4052,7 @@ ArrayUnsetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr;
+    Var *varPtr, *varPtr2, *protectedVarPtr;
     Tcl_Obj *varNameObj, *patternObj, *nameObj;
     Tcl_HashSearch search;
     const char *pattern;
@@ -4134,15 +4072,7 @@ ArrayUnsetCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Locate the array variable
-     */
-
-    varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    if (TclCheckArrayTraces(interp, varPtr, arrayPtr, varNameObj, -1)
-	    == TCL_ERROR) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
 	return TCL_ERROR;
     }
 
-- 
cgit v0.12


From 08c1a8dd343c7b9f2f21daf4b03894a3d28e1c47 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 18 Apr 2018 21:03:53 +0000
Subject: cleanup of refactor

---
 generic/tclVar.c | 19 ++++++-------------
 1 file changed, 6 insertions(+), 13 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index a4cd62b..d954f0a 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3142,7 +3142,6 @@ ArrayStartSearchCmd(
     Interp *iPtr = (Interp *)interp;
     Var *varPtr;
     Tcl_HashEntry *hPtr;
-    Tcl_Obj *varNameObj;
     int isNew;
     ArraySearch *searchPtr;
     const char *varName;
@@ -3151,9 +3150,8 @@ ArrayStartSearchCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
 	return TCL_ERROR;
     }
-    varNameObj = objv[1];
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3163,7 +3161,7 @@ ArrayStartSearchCmd(
      * traces.
      */
 
-    varName = TclGetString(varNameObj);
+    varName = TclGetString(objv[1]);
     if ((varPtr == NULL) || !TclIsVarArray(varPtr)
 	    || TclIsVarUndefined(varPtr)) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3494,16 +3492,14 @@ ArrayExistsCmd(
 {
     Interp *iPtr = (Interp *)interp;
     Var *varPtr;
-    Tcl_Obj *arrayNameObj;
     int notArray;
 
     if (objc != 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
 	return TCL_ERROR;
     }
-    arrayNameObj = objv[1];
 
-    if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3713,7 +3709,7 @@ ArrayNamesCmd(
     };
     enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
     Var *varPtr, *varPtr2;
-    Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj;
+    Tcl_Obj *nameObj, *resultObj, *patternObj;
     Tcl_HashSearch search;
     const char *pattern = NULL;
     int mode = OPT_GLOB;
@@ -3722,10 +3718,9 @@ ArrayNamesCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?");
 	return TCL_ERROR;
     }
-    varNameObj = objv[1];
     patternObj = (objc > 2 ? objv[objc-1] : NULL);
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
 	return TCL_ERROR;
     }
 
@@ -3922,7 +3917,6 @@ ArraySizeCmd(
     Tcl_Obj *const objv[])
 {
     Var *varPtr;
-    Tcl_Obj *varNameObj;
     Tcl_HashSearch search;
     Var *varPtr2;
     int size = 0;
@@ -3931,9 +3925,8 @@ ArraySizeCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
 	return TCL_ERROR;
     }
-    varNameObj = objv[1];
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
 	return TCL_ERROR;
     }
 
-- 
cgit v0.12


From 61f580bd36bb6b0f50e0d0735c1b72459434c8f5 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 18 Apr 2018 23:31:07 +0000
Subject: Refactor to bring the test for existence of an array variable into
 LocateArray().

---
 generic/tclVar.c | 132 +++++++++++++++++++------------------------------------
 1 file changed, 44 insertions(+), 88 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index d954f0a..f1c8669 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -177,7 +177,7 @@ static void		DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
 static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
 			    Var *varPtr, int flags, int index);
 static int		LocateArray(Tcl_Interp *interp, Tcl_Obj *name,
-			    Var **varPtrPtr);
+			    Var **varPtrPtr, int *isArrayPtr);
 static Tcl_Var		ObjFindNamespaceVar(Tcl_Interp *interp,
 			    Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr,
 			    int flags);
@@ -276,7 +276,8 @@ static int
 LocateArray(
     Tcl_Interp *interp,
     Tcl_Obj *name,
-    Var **varPtrPtr)
+    Var **varPtrPtr,
+    int *isArrayPtr)
 {
     Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0,
 	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
@@ -284,7 +285,13 @@ LocateArray(
     if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) {
 	return TCL_ERROR;
     }
-    *varPtrPtr = varPtr;
+    if (varPtrPtr) {
+	*varPtrPtr = varPtr;
+    }
+    if (isArrayPtr) {
+	*isArrayPtr = varPtr && !TclIsVarUndefined(varPtr)
+		&& TclIsVarArray(varPtr);
+    }
     return TCL_OK;
 }
 
@@ -3142,7 +3149,7 @@ ArrayStartSearchCmd(
     Interp *iPtr = (Interp *)interp;
     Var *varPtr;
     Tcl_HashEntry *hPtr;
-    int isNew;
+    int isNew, isArray;
     ArraySearch *searchPtr;
     const char *varName;
 
@@ -3151,19 +3158,12 @@ ArrayStartSearchCmd(
 	return TCL_ERROR;
     }
 
-    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces.
-     */
-
     varName = TclGetString(objv[1]);
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    if (!isArray) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"\"%s\" isn't an array", varName));
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
@@ -3221,7 +3221,7 @@ ArrayAnyMoreCmd(
     Interp *iPtr = (Interp *)interp;
     Var *varPtr;
     Tcl_Obj *varNameObj, *searchObj;
-    int gotValue;
+    int gotValue, isArray;
     ArraySearch *searchPtr;
 
     if (objc != 3) {
@@ -3231,18 +3231,11 @@ ArrayAnyMoreCmd(
     varNameObj = objv[1];
     searchObj = objv[2];
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces.
-     */
-
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    if (!isArray) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"\"%s\" isn't an array", TclGetString(varNameObj)));
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
@@ -3311,6 +3304,7 @@ ArrayNextElementCmd(
     Var *varPtr;
     Tcl_Obj *varNameObj, *searchObj;
     ArraySearch *searchPtr;
+    int isArray;
 
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
@@ -3319,7 +3313,7 @@ ArrayNextElementCmd(
     varNameObj = objv[1];
     searchObj = objv[2];
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
@@ -3328,9 +3322,7 @@ ArrayNextElementCmd(
      * traces - the variable may actually become an array as an effect of said
      * traces.
      */
-
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    if (!isArray) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"\"%s\" isn't an array", TclGetString(varNameObj)));
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
@@ -3404,6 +3396,7 @@ ArrayDoneSearchCmd(
     Tcl_HashEntry *hPtr;
     Tcl_Obj *varNameObj, *searchObj;
     ArraySearch *searchPtr, *prevPtr;
+    int isArray;
 
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
@@ -3412,7 +3405,7 @@ ArrayDoneSearchCmd(
     varNameObj = objv[1];
     searchObj = objv[2];
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
@@ -3422,8 +3415,7 @@ ArrayDoneSearchCmd(
      * traces.
      */
 
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    if (!isArray) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"\"%s\" isn't an array", TclGetString(varNameObj)));
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
@@ -3491,25 +3483,18 @@ ArrayExistsCmd(
     Tcl_Obj *const objv[])
 {
     Interp *iPtr = (Interp *)interp;
-    Var *varPtr;
-    int notArray;
+    int isArray;
 
     if (objc != 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
 	return TCL_ERROR;
     }
 
-    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], NULL, &isArray)) {
 	return TCL_ERROR;
     }
 
-    /*
-     * Check whether we've actually got an array variable.
-     */
-
-    notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr));
-    Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]);
+    Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]);
     return TCL_OK;
 }
 
@@ -3543,7 +3528,7 @@ ArrayGetCmd(
     Tcl_Obj **nameObjPtr, *patternObj;
     Tcl_HashSearch search;
     const char *pattern;
-    int i, count, result;
+    int i, count, result, isArray;
 
     switch (objc) {
     case 2:
@@ -3559,18 +3544,12 @@ ArrayGetCmd(
 	return TCL_ERROR;
     }
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces. If not an array, it's an empty result.
-     */
-
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    /* If not an array, it's an empty result. */
+    if (!isArray) {
 	return TCL_OK;
     }
 
@@ -3712,7 +3691,7 @@ ArrayNamesCmd(
     Tcl_Obj *nameObj, *resultObj, *patternObj;
     Tcl_HashSearch search;
     const char *pattern = NULL;
-    int mode = OPT_GLOB;
+    int isArray, mode = OPT_GLOB;
 
     if ((objc < 2) || (objc > 4)) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?");
@@ -3720,7 +3699,7 @@ ArrayNamesCmd(
     }
     patternObj = (objc > 2 ? objv[objc-1] : NULL);
 
-    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
@@ -3733,14 +3712,9 @@ ArrayNamesCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces. If not an array, the result is empty.
-     */
+    /* If not an array, the result is empty. */
 
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    if (!isArray) {
 	return TCL_OK;
     }
 
@@ -3877,14 +3851,12 @@ ArraySetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Var *varPtr;
-
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
 	return TCL_ERROR;
     }
 
-    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) {
 	return TCL_ERROR;
     }
 
@@ -3919,24 +3891,20 @@ ArraySizeCmd(
     Var *varPtr;
     Tcl_HashSearch search;
     Var *varPtr2;
-    int size = 0;
+    int isArray, size = 0;
 
     if (objc != 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
 	return TCL_ERROR;
     }
 
-    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces. We can only iterate over the array if it exists...
-     */
+    /* We can only iterate over the array if it exists... */
 
-    if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+    if (isArray) {
 	/*
 	 * Must iterate in order to get chance to check for present but
 	 * "undefined" entries.
@@ -3983,6 +3951,7 @@ ArrayStatsCmd(
     Var *varPtr;
     Tcl_Obj *varNameObj;
     char *stats;
+    int isArray;
 
     if (objc != 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
@@ -3990,18 +3959,11 @@ ArrayStatsCmd(
     }
     varNameObj = objv[1];
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces.
-     */
-
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    if (!isArray) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"\"%s\" isn't an array", TclGetString(varNameObj)));
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
@@ -4050,6 +4012,7 @@ ArrayUnsetCmd(
     Tcl_HashSearch search;
     const char *pattern;
     const int unsetFlags = 0;	/* Should this be TCL_LEAVE_ERR_MSG? */
+    int isArray;
 
     switch (objc) {
     case 2:
@@ -4065,18 +4028,11 @@ ArrayUnsetCmd(
 	return TCL_ERROR;
     }
 
-    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr)) {
+    if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces.
-     */
-
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
+    if (!isArray) {
 	return TCL_OK;
     }
 
-- 
cgit v0.12


From 8d0340e39e077c5577acacc1a175b5c412c8905b Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 18 Apr 2018 23:41:48 +0000
Subject: Refactor error reporting when value is not an expected array variable
 name.

---
 generic/tclVar.c | 56 ++++++++++++++++++++------------------------------------
 1 file changed, 20 insertions(+), 36 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index f1c8669..92ae183 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -178,6 +178,7 @@ static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
 			    Var *varPtr, int flags, int index);
 static int		LocateArray(Tcl_Interp *interp, Tcl_Obj *name,
 			    Var **varPtrPtr, int *isArrayPtr);
+static int		NotArrayError(Tcl_Interp *interp, Tcl_Obj *name);
 static Tcl_Var		ObjFindNamespaceVar(Tcl_Interp *interp,
 			    Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr,
 			    int flags);
@@ -294,6 +295,19 @@ LocateArray(
     }
     return TCL_OK;
 }
+
+static int
+NotArrayError(
+    Tcl_Interp *interp,
+    Tcl_Obj *name)
+{
+    const char *nameStr = Tcl_GetString(name);
+
+    Tcl_SetObjResult(interp,
+	    Tcl_ObjPrintf("\"%s\" isn't an array", nameStr));
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL);
+    return TCL_ERROR;
+}
 
 /*
  *----------------------------------------------------------------------
@@ -3162,18 +3176,15 @@ ArrayStartSearchCmd(
 	return TCL_ERROR;
     }
 
-    varName = TclGetString(objv[1]);
     if (!isArray) {
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"\"%s\" isn't an array", varName));
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
-	return TCL_ERROR;
+	return NotArrayError(interp, objv[1]);
     }
 
     /*
      * Make a new array search with a free name.
      */
 
+    varName = TclGetString(objv[1]);
     searchPtr = ckalloc(sizeof(ArraySearch));
     hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
     if (isNew) {
@@ -3236,11 +3247,7 @@ ArrayAnyMoreCmd(
     }
 
     if (!isArray) {
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"\"%s\" isn't an array", TclGetString(varNameObj)));
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
-		TclGetString(varNameObj), NULL);
-	return TCL_ERROR;
+	return NotArrayError(interp, varNameObj);
     }
 
     /*
@@ -3317,17 +3324,8 @@ ArrayNextElementCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces.
-     */
     if (!isArray) {
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"\"%s\" isn't an array", TclGetString(varNameObj)));
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
-		TclGetString(varNameObj), NULL);
-	return TCL_ERROR;
+	return NotArrayError(interp, varNameObj);
     }
 
     /*
@@ -3409,18 +3407,8 @@ ArrayDoneSearchCmd(
 	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces - the variable may actually become an array as an effect of said
-     * traces.
-     */
-
     if (!isArray) {
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"\"%s\" isn't an array", TclGetString(varNameObj)));
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
-		TclGetString(varNameObj), NULL);
-	return TCL_ERROR;
+	return NotArrayError(interp, varNameObj);
     }
 
     /*
@@ -3964,11 +3952,7 @@ ArrayStatsCmd(
     }
 
     if (!isArray) {
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"\"%s\" isn't an array", TclGetString(varNameObj)));
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
-		TclGetString(varNameObj), NULL);
-	return TCL_ERROR;
+	return NotArrayError(interp, varNameObj);
     }
 
     stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
-- 
cgit v0.12


From df94eecf119611a2fa8de1abb3abe59269be7550 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 19 Apr 2018 01:39:38 +0000
Subject: An [array set] from a dict can only take shortcuts when the dict is
 "pure", that is, has no string rep.

---
 generic/tclVar.c |  2 +-
 tests/var.test   | 12 ++++++++++++
 2 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index e540c49..d4e5339 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3411,7 +3411,7 @@ TclArraySet(
      * Install the contents of the dictionary or list into the array.
      */
 
-    if (arrayElemObj->typePtr == &tclDictType) {
+    if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
 	Tcl_Obj *keyPtr, *valuePtr;
 	Tcl_DictSearch search;
 	int done;
diff --git a/tests/var.test b/tests/var.test
index 30e340e..aadeb34 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -761,6 +761,18 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup {
 } -cleanup {
     unset -nocomplain ::a ::elements
 } -result {}
+test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup {
+    unset -nocomplain a d
+    set d {p 1 p 2}
+    dict get $d p
+    set foo 0
+} -body {
+    trace add variable a write "[list incr [namespace which -variable foo]];#"
+    array set a $d
+    set foo
+} -cleanup {
+    unset -nocomplain a d foo
+} -result 2
 
 test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
     set already 0
-- 
cgit v0.12


From 75bd116527ce94efc1c14c6dc82c526614ed6c7f Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 19 Apr 2018 02:01:29 +0000
Subject: Fold TclArraySet() into its only caller. tclEnv.c no longer calls it

---
 generic/tclInt.h |   2 -
 generic/tclVar.c | 311 +++++++++++++++++++++++++------------------------------
 2 files changed, 141 insertions(+), 172 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 371e3fa..4db4576 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2864,8 +2864,6 @@ MODULE_SCOPE void	TclArgumentBCRelease(Tcl_Interp *interp,
 			    CmdFrame *cfPtr);
 MODULE_SCOPE void	TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
 			    CmdFrame **cfPtrPtr, int *wordPtr);
-MODULE_SCOPE int	TclArraySet(Tcl_Interp *interp,
-			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
 MODULE_SCOPE double	TclBignumToDouble(const mp_int *bignum);
 MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
 			    int strLen, const unsigned char *pattern,
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 84f2d7b..c4952be 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -2968,175 +2968,6 @@ Tcl_LappendObjCmd(
 /*
  *----------------------------------------------------------------------
  *
- * TclArraySet --
- *
- *	Set the elements of an array. If there are no elements to set, create
- *	an empty array. This routine is used by the Tcl_ArrayObjCmd and by the
- *	TclSetupEnv routine.
- *
- * Results:
- *	A standard Tcl result object.
- *
- * Side effects:
- *	A variable will be created if one does not already exist.
- *	Callers must Incr arrayNameObj if they pland to Decr it.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclArraySet(
-    Tcl_Interp *interp,		/* Current interpreter. */
-    Tcl_Obj *arrayNameObj,	/* The array name. */
-    Tcl_Obj *arrayElemObj)	/* The array elements list or dict. If this is
-				 * NULL, create an empty array. */
-{
-    Var *varPtr, *arrayPtr;
-    int result, i;
-
-    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
-	    /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
-	    /*createPart2*/ 1, &arrayPtr);
-    if (varPtr == NULL) {
-	return TCL_ERROR;
-    }
-    if (arrayPtr) {
-	CleanupVar(varPtr, arrayPtr);
-	TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
-		TclGetString(arrayNameObj), NULL);
-	return TCL_ERROR;
-    }
-
-    if (arrayElemObj == NULL) {
-	goto ensureArray;
-    }
-
-    /*
-     * Install the contents of the dictionary or list into the array.
-     */
-
-    if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
-	Tcl_Obj *keyPtr, *valuePtr;
-	Tcl_DictSearch search;
-	int done;
-
-	if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
-	    return TCL_ERROR;
-	}
-	if (done == 0) {
-	    /*
-	     * Empty, so we'll just force the array to be properly existing
-	     * instead.
-	     */
-
-	    goto ensureArray;
-	}
-
-	/*
-	 * Don't need to look at result of Tcl_DictObjFirst as we've just
-	 * successfully used a dictionary operation on the same object.
-	 */
-
-	for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
-		&keyPtr, &valuePtr, &done) ; !done ;
-		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
-	    /*
-	     * At this point, it would be nice if the key was directly usable
-	     * by the array. This isn't the case though.
-	     */
-
-	    Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
-		    keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
-
-	    if ((elemVarPtr == NULL) ||
-		    (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
-		    keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
-		Tcl_DictObjDone(&search);
-		return TCL_ERROR;
-	    }
-	}
-	return TCL_OK;
-    } else {
-	/*
-	 * Not a dictionary, so assume (and convert to, for backward-
-	 * -compatibility reasons) a list.
-	 */
-
-	int elemLen;
-	Tcl_Obj **elemPtrs, *copyListObj;
-
-	result = TclListObjGetElements(interp, arrayElemObj,
-		&elemLen, &elemPtrs);
-	if (result != TCL_OK) {
-	    return result;
-	}
-	if (elemLen & 1) {
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		    "list must have an even number of elements", -1));
-	    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
-	    return TCL_ERROR;
-	}
-	if (elemLen == 0) {
-	    goto ensureArray;
-	}
-
-	/*
-	 * We needn't worry about traces invalidating arrayPtr: should that be
-	 * the case, TclPtrSetVarIdx will return NULL so that we break out of
-	 * the loop and return an error.
-	 */
-
-	copyListObj = TclListObjCopy(NULL, arrayElemObj);
-	for (i=0 ; i<elemLen ; i+=2) {
-	    Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
-		    elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
-
-	    if ((elemVarPtr == NULL) ||
-		    (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
-		    elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
-		result = TCL_ERROR;
-		break;
-	    }
-	}
-	Tcl_DecrRefCount(copyListObj);
-	return result;
-    }
-
-    /*
-     * The list is empty make sure we have an array, or create one if
-     * necessary.
-     */
-
-  ensureArray:
-    if (varPtr != NULL) {
-	if (TclIsVarArray(varPtr)) {
-	    /*
-	     * Already an array, done.
-	     */
-
-	    return TCL_OK;
-	}
-	if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
-	    /*
-	     * Either an array element, or a scalar: lose!
-	     */
-
-	    TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
-		    needArray, -1);
-	    Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
-	    return TCL_ERROR;
-	}
-    }
-    TclSetVarArray(varPtr);
-    varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
-    TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
-    return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * ArrayStartSearchCmd --
  *
  *	This object-based function is invoked to process the "array
@@ -3839,6 +3670,11 @@ ArraySetCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
+    Tcl_Obj *arrayNameObj;
+    Tcl_Obj *arrayElemObj;
+    Var *varPtr, *arrayPtr;
+    int result, i;
+
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
 	return TCL_ERROR;
@@ -3848,7 +3684,142 @@ ArraySetCmd(
 	return TCL_ERROR;
     }
 
-    return TclArraySet(interp, objv[1], objv[2]);
+    arrayNameObj = objv[1];
+    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
+	    /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
+	    /*createPart2*/ 1, &arrayPtr);
+    if (varPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (arrayPtr) {
+	CleanupVar(varPtr, arrayPtr);
+	TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+		TclGetString(arrayNameObj), NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Install the contents of the dictionary or list into the array.
+     */
+
+    arrayElemObj = objv[2];
+    if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
+	Tcl_Obj *keyPtr, *valuePtr;
+	Tcl_DictSearch search;
+	int done;
+
+	if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (done == 0) {
+	    /*
+	     * Empty, so we'll just force the array to be properly existing
+	     * instead.
+	     */
+
+	    goto ensureArray;
+	}
+
+	/*
+	 * Don't need to look at result of Tcl_DictObjFirst as we've just
+	 * successfully used a dictionary operation on the same object.
+	 */
+
+	for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
+		&keyPtr, &valuePtr, &done) ; !done ;
+		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
+	    /*
+	     * At this point, it would be nice if the key was directly usable
+	     * by the array. This isn't the case though.
+	     */
+
+	    Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+		    keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+
+	    if ((elemVarPtr == NULL) ||
+		    (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
+		    keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
+		Tcl_DictObjDone(&search);
+		return TCL_ERROR;
+	    }
+	}
+	return TCL_OK;
+    } else {
+	/*
+	 * Not a dictionary, so assume (and convert to, for backward-
+	 * -compatibility reasons) a list.
+	 */
+
+	int elemLen;
+	Tcl_Obj **elemPtrs, *copyListObj;
+
+	result = TclListObjGetElements(interp, arrayElemObj,
+		&elemLen, &elemPtrs);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	if (elemLen & 1) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "list must have an even number of elements", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
+	    return TCL_ERROR;
+	}
+	if (elemLen == 0) {
+	    goto ensureArray;
+	}
+
+	/*
+	 * We needn't worry about traces invalidating arrayPtr: should that be
+	 * the case, TclPtrSetVarIdx will return NULL so that we break out of
+	 * the loop and return an error.
+	 */
+
+	copyListObj = TclListObjCopy(NULL, arrayElemObj);
+	for (i=0 ; i<elemLen ; i+=2) {
+	    Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+		    elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+
+	    if ((elemVarPtr == NULL) ||
+		    (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
+		    elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
+		result = TCL_ERROR;
+		break;
+	    }
+	}
+	Tcl_DecrRefCount(copyListObj);
+	return result;
+    }
+
+    /*
+     * The list is empty make sure we have an array, or create one if
+     * necessary.
+     */
+
+  ensureArray:
+    if (varPtr != NULL) {
+	if (TclIsVarArray(varPtr)) {
+	    /*
+	     * Already an array, done.
+	     */
+
+	    return TCL_OK;
+	}
+	if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
+	    /*
+	     * Either an array element, or a scalar: lose!
+	     */
+
+	    TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
+		    needArray, -1);
+	    Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+	    return TCL_ERROR;
+	}
+    }
+    TclSetVarArray(varPtr);
+    varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
+    TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+    return TCL_OK;
 }
 
 /*
-- 
cgit v0.12


From ddb7bbe66c5b805d02fc11f55c53e909e1af45ac Mon Sep 17 00:00:00 2001
From: oehhar <harald.oehlmann@elmicron.de>
Date: Thu, 19 Apr 2018 11:48:28 +0000
Subject: correct msgcat test numbering for section util from 15.x (used twice)
 to 18.x

---
 tests/msgcat.test | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/tests/msgcat.test b/tests/msgcat.test
index d38152b..12030fb 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -1317,33 +1317,33 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
 
     interp bgerror {} $bgerrorsaved
 
-    # Tests msgcat-15.*: [mcutil]
+    # Tests msgcat-18.*: [mcutil]
 
-    test msgcat-15.5 {mcutil - no argument} -body {
+    test msgcat-18.1 {mcutil - no argument} -body {
 	mcutil
     } -returnCodes 1\
     -result {wrong # args: should be "mcutil subcommand ?arg ...?"}
 
-    test msgcat-15.6 {mcutil - wrong argument} -body {
+    test msgcat-18.2 {mcutil - wrong argument} -body {
 	mcutil junk
     } -returnCodes 1\
     -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
     
-    test msgcat-15.7 {mcutil - partial argument} -body {
+    test msgcat-18.3 {mcutil - partial argument} -body {
 	mcutil getsystem
     } -returnCodes 1\
     -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
     
-    test msgcat-15.8 {mcutil getpreferences - no argument} -body {
+    test msgcat-18.4 {mcutil getpreferences - no argument} -body {
 	mcutil getpreferences
     } -returnCodes 1\
     -result {wrong # args: should be "mcutil getpreferences locale"}
     
-    test msgcat-15.9 {mcutil getpreferences - DE_de} -body {
+    test msgcat-18.5 {mcutil getpreferences - DE_de} -body {
 	mcutil getpreferences DE_de
     } -result {de_de de {}}
     
-    test msgcat-15.10 {mcutil getsystemlocale - wrong argument} -body {
+    test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body {
 	mcutil getsystemlocale DE_de
     } -returnCodes 1\
     -result {wrong # args: should be "mcutil getsystemlocale"}
@@ -1351,7 +1351,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
     # The result is system dependent
     # So just test if it runs
     # The environment variable version was test with test 0.x
-    test msgcat-15.11 {mcutil getsystemlocale} -body {
+    test msgcat-18.7 {mcutil getsystemlocale} -body {
 	mcutil getsystemlocale
 	set ok ok
     } -result {ok}
-- 
cgit v0.12


From 5c2ea0542f62da981d08766756c2e421db40955c Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 19 Apr 2018 17:46:37 +0000
Subject: Adapt [array for] to use the refactored routines.

---
 generic/tclVar.c | 42 +++++-------------------------------------
 1 file changed, 5 insertions(+), 37 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index 7a71990..51eec61 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3043,12 +3043,10 @@ ArrayForNRCmd(
     int objc,
     Tcl_Obj *const *objv)
 {
-    Interp *iPtr = (Interp *) interp;
     Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
     ArraySearch *searchPtr = NULL;
     Var *varPtr;
-    Var *arrayPtr;
-    int numVars;
+    int isArray, numVars;
 
     /*
      * array for {k v} a body
@@ -3064,7 +3062,6 @@ ArrayForNRCmd(
      * Parse arguments.
      */
 
-
     if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) {
 	return TCL_ERROR;
     }
@@ -3078,41 +3075,12 @@ ArrayForNRCmd(
 
     arrayNameObj = objv[2];
 
-    /*
-     * Locate the array variable.
-     */
-
-    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
-    /*
-     * Special array trace used to keep the env array in sync for array names,
-     * array get, etc.
-     */
-
-    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
-	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
-	if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL,
-		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
-		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
-	    return TCL_ERROR;
-	}
+    if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
+	return TCL_ERROR;
     }
 
-    /*
-     * Verify that it is indeed an array variable. This test comes after the
-     * traces; the variable may actually become an array as an effect of said
-     * traces.
-     */
-
-    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
-	    || TclIsVarUndefined(varPtr)) {
-	const char *varName = Tcl_GetString(arrayNameObj);
-
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"\"%s\" isn't an array", varName));
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
-	return TCL_ERROR;
+    if (!isArray) {
+	return NotArrayError(interp, arrayNameObj);
     }
 
     /*
-- 
cgit v0.12


From 1734eed89f76598661a4ce4c7d5e43ce7fe4368c Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 19 Apr 2018 22:29:00 +0000
Subject: Slightly improved (more fail-safe) surrogate handling for
 TCL_UTF_MAX>3. Backported from latest TIP 389 implementation. (to be used for
 androwish)

---
 generic/tclUtf.c | 21 ++++++++++++++-------
 1 file changed, 14 insertions(+), 7 deletions(-)

diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 6255a4e..0d88d36 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -154,19 +154,26 @@ Tcl_UniCharToUtf(
 	    return 2;
 	}
 	if (ch <= 0xFFFF) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX > 3
 	    if ((ch & 0xF800) == 0xD800) {
 		if (ch & 0x0400) {
 		    /* Low surrogate */
-		    buf[3] = (char) ((ch | 0x80) & 0xBF);
-		    buf[2] |= (char) (((ch >> 6) | 0x80) & 0x8F);
-		    return 4;
+		    if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80)
+			    && ((buf[2] & 0xCF) == 0)) {
+			/* Previous Tcl_UniChar was a High surrogate, so combine */
+			buf[3] = (char) ((ch & 0x3F) | 0x80);
+			buf[2] |= (char) (((ch >> 6) & 0x0F) | 0x80);
+			return 4;
+		    }
+		    /* Previous Tcl_UniChar was not a High surrogate, so just output */
 		} else {
 		    /* High surrogate */
 		    ch += 0x40;
-		    buf[2] = (char) (((ch << 4) | 0x80) & 0xB0);
-		    buf[1] = (char) (((ch >> 2) | 0x80) & 0xBF);
-		    buf[0] = (char) (((ch >> 8) | 0xF0) & 0xF7);
+		    /* Fill buffer with specific 3-byte (invalid) byte combination,
+		       so following Low surrogate can recognize it and combine */
+		    buf[2] = (char) ((ch << 4) & 0x30);
+		    buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80);
+		    buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0);
 		    return 0;
 		}
 	    }
-- 
cgit v0.12


From ae76fbd559e8e30a6cb4c448bf4c924cbd79841b Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 20 Apr 2018 20:17:17 +0000
Subject: DeleteArray has only one caller. It is called on the "dummy" variable
 that is created during unset, and which cannot be reached by resolving any
 name. It cannot have VAR_SEARCH_ACTIVE set because the sole thing that sets
 that flag is an [array startsearch] applied to a named variable.

---
 generic/tclVar.c | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index c4952be..ed16c9f 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -5324,9 +5324,6 @@ DeleteArray(
     Tcl_Obj *objPtr;
     VarTrace *tracePtr;
 
-    if (varPtr->flags & VAR_SEARCH_ACTIVE) {
-	DeleteSearches(iPtr, varPtr);
-    }
     for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search);
 	    elPtr != NULL; elPtr = VarHashNextVar(&search)) {
 	if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
-- 
cgit v0.12


From 8e06fd796be19c40e0e82a7d9c9e54d34e975504 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Sun, 22 Apr 2018 13:22:20 +0000
Subject: [46a2410650] compiled [unset] was bypassing cleanup of active array
 search. Overdue thanks to Andy Goth for tests and report.

---
 generic/tclExecute.c |  3 ++-
 tests/var.test       | 16 ++++++++++++++++
 2 files changed, 18 insertions(+), 1 deletion(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5bc5c2d..af44323 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4169,7 +4169,8 @@ TEBCresume(
 	}
 	TRACE(("%s %u \"%.30s\" => ",
 		(flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
-	if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) {
+	if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)
+		&& !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) {
 	    varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
 	    if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
 		/*
diff --git a/tests/var.test b/tests/var.test
index b235e5d..8d86fce 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -776,6 +776,22 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup {
     }
     set x "If you see this, it worked"
 } -result "If you see this, it worked"
+test var-13.2 {unset array with search, bug 46a2410650} -body {
+    apply {{} {
+	array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
+	set s [array startsearch a]
+	unset a([array nextelement a $s])
+	array nextelement a $s
+    }}
+} -returnCodes error -result {couldn't find search "s-1-a"}
+test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body {
+    apply {{} {
+	array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
+	set s [array startsearch a]
+        unset a(ff)
+	array nextelement a $s
+    }}
+} -returnCodes error -result {couldn't find search "s-1-a"}
 
 test var-14.1 {array names syntax} -body {
     array names foo bar baz snafu
-- 
cgit v0.12


From 95f246935924442788522c93b95723eeef602e77 Mon Sep 17 00:00:00 2001
From: bll <brad.lanam.comp@gmail.com>
Date: Mon, 23 Apr 2018 12:58:41 +0000
Subject: Rework 'array for' to pass the arrayNameObj to the NRE routines
 rather than saving it in the ArraySearch structure (which will not work).
 Create ArrayPopulateSearch to consolidate duplicate code.

---
 generic/tclVar.c | 114 ++++++++++++++++++++++++-------------------------------
 1 file changed, 49 insertions(+), 65 deletions(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index 889e6ba..f22815c 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -166,7 +166,6 @@ typedef struct ArraySearch {
     struct ArraySearch *nextPtr;/* Next in list of all active searches for
 				 * this variable, or NULL if this is the last
 				 * one. */
-    Tcl_Obj *arrayNameObj;      /* name of the array object */
 } ArraySearch;
 
 /*
@@ -175,6 +174,7 @@ typedef struct ArraySearch {
 
 static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
 			    Tcl_Obj *patternPtr, int includeLinks);
+static void             ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr);
 static void             ArrayDoneSearch (Interp *iPtr, Var *varPtr, ArraySearch *searchPtr);
 static Tcl_NRPostProc   ArrayForLoopCallback;
 static int              ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
@@ -2912,7 +2912,6 @@ Tcl_LappendObjCmd(
  * ArrayForObjCmd
  * ArrayForNRCmd
  * ArrayForLoopCallback
- * ArrayObjFirst
  * ArrayObjNext
  *
  *  These functions implement the "array for" Tcl command.
@@ -2932,46 +2931,13 @@ Tcl_LappendObjCmd(
  *  ArrayForLoopCallback() iterates over the entire array, executing
  *  the body each time.
  *
- *  ArrayObjFirst() Does not execute the body or set the key/value variables.
- *
  *----------------------------------------------------------------------
  */
-void
-ArrayObjFirst(
-    Tcl_Interp *interp,
-    Tcl_Obj *arrayNameObj,
-    Var *varPtr,
-    ArraySearch *searchPtr)
-{
-    Interp *iPtr = (Interp *) interp;
-    Tcl_HashEntry   *hPtr;
-    int             isNew;
-
-    /* this code is duplicated from arraystartsearchcmd,
-       excepting that arrayNameObj is set */
-    searchPtr->varPtr = varPtr;
-    searchPtr->arrayNameObj = arrayNameObj;
-
-    /* add the search to the search table */
-    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
-    if (isNew) {
-	searchPtr->id = 1;
-	varPtr->flags |= VAR_SEARCH_ACTIVE;
-        searchPtr->nextPtr = NULL;
-    } else {
-	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
-	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
-    }
-    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
-	    &searchPtr->search);
-    Tcl_SetHashValue(hPtr, searchPtr);
-    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(arrayNameObj));
-    Tcl_IncrRefCount(searchPtr->name);
-}
 
-int
+static int
 ArrayObjNext(
     Tcl_Interp *interp,
+    Tcl_Obj *arrayNameObj,      /* array */
     Var *varPtr,                /* array */
     ArraySearch *searchPtr,
     Tcl_Obj **keyPtrPtr,	/* Pointer to a variable to have the key
@@ -3019,7 +2985,7 @@ ArrayObjNext(
 
     keyObj = VarHashGetKey(varPtr);
     *keyPtrPtr = keyObj;
-    valueObj = Tcl_ObjGetVar2(interp, searchPtr->arrayNameObj,
+    valueObj = Tcl_ObjGetVar2(interp, arrayNameObj,
         keyObj, TCL_LEAVE_ERR_MSG);
     *valuePtrPtr = valueObj;
 
@@ -3088,8 +3054,7 @@ ArrayForNRCmd(
      */
 
     searchPtr = ckalloc(sizeof(ArraySearch));
-    searchPtr->arrayNameObj = NULL;
-    ArrayObjFirst(interp, arrayNameObj, varPtr, searchPtr);
+    ArrayPopulateSearch (interp, arrayNameObj, varPtr, searchPtr);
 
     /*
      * Make sure that these objects (which we need throughout the body of the
@@ -3105,7 +3070,7 @@ ArrayForNRCmd(
      */
 
     TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
-	    NULL, scriptObj);
+	    arrayNameObj, scriptObj);
     return TCL_OK;
 }
 
@@ -3118,6 +3083,7 @@ ArrayForLoopCallback(
     Interp *iPtr = (Interp *) interp;
     ArraySearch *searchPtr = data[0];
     Tcl_Obj *varListObj = data[1];
+    Tcl_Obj *arrayNameObj = data[2];
     Tcl_Obj *scriptObj = data[3];
     Tcl_Obj **varv;
     Tcl_Obj *keyObj, *valueObj;
@@ -3130,8 +3096,6 @@ ArrayForLoopCallback(
      */
 
     done = TCL_ERROR;
-    varPtr = TclObjLookupVarEx(interp, searchPtr->arrayNameObj, NULL, /*flags*/ 0,
-	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 
     if (result == TCL_CONTINUE) {
 	result = TCL_OK;
@@ -3153,7 +3117,14 @@ ArrayForLoopCallback(
 
     keyObj = NULL;
     valueObj = NULL;
-    done = ArrayObjNext (interp, varPtr, searchPtr, &keyObj, &valueObj);
+    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
+	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+    if (varPtr == NULL) {
+      done = TCL_ERROR;
+    } else {
+      done = ArrayObjNext (interp, arrayNameObj, varPtr,
+          searchPtr, &keyObj, &valueObj);
+    }
 
     result = TCL_OK;
     if (done != TCL_CONTINUE) {
@@ -3185,7 +3156,7 @@ ArrayForLoopCallback(
      */
 
     TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
-	    NULL, scriptObj);
+	    arrayNameObj, scriptObj);
     return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
 
     /*
@@ -3208,6 +3179,37 @@ ArrayForLoopCallback(
 }
 
 /*
+ * ArrayPopulateSearch
+ */
+static void
+ArrayPopulateSearch(
+    Tcl_Interp  *interp,
+    Tcl_Obj     *arrayNameObj,
+    Var         *varPtr,
+    ArraySearch *searchPtr)
+{
+    Interp *iPtr = (Interp *)interp;
+    Tcl_HashEntry *hPtr;
+    int isNew;
+
+    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
+    if (isNew) {
+	searchPtr->id = 1;
+	varPtr->flags |= VAR_SEARCH_ACTIVE;
+	searchPtr->nextPtr = NULL;
+    } else {
+	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
+	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
+    }
+    searchPtr->varPtr = varPtr;
+    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
+	    &searchPtr->search);
+    Tcl_SetHashValue(hPtr, searchPtr);
+    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
+        TclGetString(arrayNameObj));
+    Tcl_IncrRefCount(searchPtr->name);
+}
+/*
  *----------------------------------------------------------------------
  *
  * ArrayStartSearchCmd --
@@ -3234,12 +3236,9 @@ ArrayStartSearchCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    Interp *iPtr = (Interp *)interp;
     Var *varPtr;
-    Tcl_HashEntry *hPtr;
-    int isNew, isArray;
+    int isArray;
     ArraySearch *searchPtr;
-    const char *varName;
 
     if (objc != 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
@@ -3258,23 +3257,8 @@ ArrayStartSearchCmd(
      * Make a new array search with a free name.
      */
 
-    varName = TclGetString(objv[1]);
     searchPtr = ckalloc(sizeof(ArraySearch));
-    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
-    if (isNew) {
-	searchPtr->id = 1;
-	varPtr->flags |= VAR_SEARCH_ACTIVE;
-	searchPtr->nextPtr = NULL;
-    } else {
-	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
-	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
-    }
-    searchPtr->varPtr = varPtr;
-    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
-	    &searchPtr->search);
-    Tcl_SetHashValue(hPtr, searchPtr);
-    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1]));
-    Tcl_IncrRefCount(searchPtr->name);
+    ArrayPopulateSearch (interp, objv[1], varPtr, searchPtr);
     Tcl_SetObjResult(interp, searchPtr->name);
     return TCL_OK;
 }
-- 
cgit v0.12


From 523d6ea42c58bae3ffe912865264036fd8d1b311 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 23 Apr 2018 13:51:05 +0000
Subject: Dup test name.

---
 tests/string.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/string.test b/tests/string.test
index 2300f08..35b6880 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -487,7 +487,7 @@ test string-5.19.$noComp {string index, bytearray object out of bounds} {
 test string-5.20.$noComp {string index, bytearray object out of bounds} {
     run {string index [binary format I* {0x50515253 0x52}] 20}
 } {}
-test string-5.21 {string index, surrogates, bug [11ae2be95dac9417]} fullutf {
+test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} fullutf {
     list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]
 } [list \U100000 {} b]
 
-- 
cgit v0.12


From 9acb063268f48f19e3c67a877f2c83e15fd1019d Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 23 Apr 2018 14:56:44 +0000
Subject: Add some state to encodings, so we can do better surrogate handling
 for TCL_UTF_MAX >= 4. Backported from TIP #389.

---
 generic/tclEncoding.c | 79 ++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 53 insertions(+), 26 deletions(-)

diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 2548b73..6b440e7 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -2296,8 +2296,11 @@ UtfToUtfProc(
     const char *srcStart, *srcEnd, *srcClose;
     const char *dstStart, *dstEnd;
     int result, numChars, charLimit = INT_MAX;
-    Tcl_UniChar ch = 0;
+    Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
 
+    if (flags & TCL_ENCODING_START) {
+    	*statePtr = 0;
+    }
     result = TCL_OK;
 
     srcStart = src;
@@ -2349,12 +2352,19 @@ UtfToUtfProc(
 	     * incomplete char its bytes are made to represent themselves.
 	     */
 
-	    ch = (unsigned char) *src;
+	    *chPtr = (unsigned char) *src;
 	    src += 1;
-	    dst += Tcl_UniCharToUtf(ch, dst);
+	    dst += Tcl_UniCharToUtf(*chPtr, dst);
 	} else {
-	    src += TclUtfToUniChar(src, &ch);
-	    dst += Tcl_UniCharToUtf(ch, dst);
+	    int len = TclUtfToUniChar(src, chPtr);
+	    src += len;
+	    dst += Tcl_UniCharToUtf(*chPtr, dst);
+#if TCL_UTF_MAX == 4
+	    if (!len) {
+		src += TclUtfToUniChar(src, chPtr);
+		dst += Tcl_UniCharToUtf(*chPtr, dst);
+	    }
+#endif
 	}
     }
 
@@ -2410,8 +2420,11 @@ UnicodeToUtfProc(
     const char *srcStart, *srcEnd;
     const char *dstEnd, *dstStart;
     int result, numChars, charLimit = INT_MAX;
-    Tcl_UniChar ch = 0;
+    Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
 
+    if (flags & TCL_ENCODING_START) {
+    	*statePtr = 0;
+    }
     if (flags & TCL_ENCODING_CHAR_LIMIT) {
 	charLimit = *dstCharsPtr;
     }
@@ -2439,11 +2452,11 @@ UnicodeToUtfProc(
 	 * Tcl_UniChar-size data.
 	 */
 
-	ch = *(Tcl_UniChar *)src;
-	if (ch && ch < 0x80) {
-	    *dst++ = (ch & 0xFF);
+	*chPtr = *(Tcl_UniChar *)src;
+	if (*chPtr && *chPtr < 0x80) {
+	    *dst++ = (*chPtr & 0xFF);
 	} else {
-	    dst += Tcl_UniCharToUtf(ch, dst);
+	    dst += Tcl_UniCharToUtf(*chPtr, dst);
 	}
 	src += sizeof(Tcl_UniChar);
     }
@@ -2500,8 +2513,11 @@ UtfToUnicodeProc(
 {
     const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
     int result, numChars;
-    Tcl_UniChar ch = 0;
+    Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
 
+    if (flags & TCL_ENCODING_START) {
+    	*statePtr = 0;
+    }
     srcStart = src;
     srcEnd = src + srcLen;
     srcClose = srcEnd;
@@ -2527,7 +2543,7 @@ UtfToUnicodeProc(
 	    result = TCL_CONVERT_NOSPACE;
 	    break;
 	}
-	src += TclUtfToUniChar(src, &ch);
+	src += TclUtfToUniChar(src, chPtr);
 
 	/*
 	 * Need to handle this in a way that won't cause misalignment by
@@ -2536,23 +2552,23 @@ UtfToUnicodeProc(
 
 #ifdef WORDS_BIGENDIAN
 #if TCL_UTF_MAX > 4
-	*dst++ = (ch >> 24);
-	*dst++ = ((ch >> 16) & 0xFF);
-	*dst++ = ((ch >> 8) & 0xFF);
-	*dst++ = (ch & 0xFF);
+	*dst++ = (*chPtr >> 24);
+	*dst++ = ((*chPtr >> 16) & 0xFF);
+	*dst++ = ((*chPtr >> 8) & 0xFF);
+	*dst++ = (*chPtr & 0xFF);
 #else
-	*dst++ = (ch >> 8);
-	*dst++ = (ch & 0xFF);
+	*dst++ = (*chPtr >> 8);
+	*dst++ = (*chPtr & 0xFF);
 #endif
 #else
 #if TCL_UTF_MAX > 4
-	*dst++ = (ch & 0xFF);
-	*dst++ = ((ch >> 8) & 0xFF);
-	*dst++ = ((ch >> 16) & 0xFF);
-	*dst++ = (ch >> 24);
+	*dst++ = (*chPtr & 0xFF);
+	*dst++ = ((*chPtr >> 8) & 0xFF);
+	*dst++ = ((*chPtr >> 16) & 0xFF);
+	*dst++ = (*chPtr >> 24);
 #else
-	*dst++ = (ch & 0xFF);
-	*dst++ = (ch >> 8);
+	*dst++ = (*chPtr & 0xFF);
+	*dst++ = (*chPtr >> 8);
 #endif
 #endif
     }
@@ -2754,7 +2770,7 @@ TableFromUtfProc(
 	}
 	len = TclUtfToUniChar(src, &ch);
 
-#if TCL_UTF_MAX > 3
+#if TCL_UTF_MAX > 4
 	/*
 	 * This prevents a crash condition. More evaluation is required for
 	 * full support of int Tcl_UniChar. [Bug 1004065]
@@ -2763,6 +2779,10 @@ TableFromUtfProc(
 	if (ch & 0xffff0000) {
 	    word = 0;
 	} else
+#elif TCL_UTF_MAX == 4
+	if (!len) {
+	    word = 0;
+	} else
 #endif
 	    word = fromUnicode[(ch >> 8)][ch & 0xff];
 
@@ -2960,11 +2980,18 @@ Iso88591FromUtfProc(
 	 * Check for illegal characters.
 	 */
 
-	if (ch > 0xff) {
+	if (ch > 0xff
+#if TCL_UTF_MAX == 4
+		|| !len
+#endif
+		) {
 	    if (flags & TCL_ENCODING_STOPONERROR) {
 		result = TCL_CONVERT_UNKNOWN;
 		break;
 	    }
+#if TCL_UTF_MAX == 4
+	    if (!len) len = 4;
+#endif
 
 	    /*
 	     * Plunge on, using '?' as a fallback character.
-- 
cgit v0.12


From 4519681dcd20c967abbe68795911c77c317fab4f Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 23 Apr 2018 23:23:00 +0000
Subject: Bug-fix in Tcl_UtfAtIndex (for TCL_UTF_MAX=4 only). With test-case
 (in "string totitle") demonstrating the bug.

---
 generic/tclUtf.c  |  8 ++++++++
 tests/string.test | 11 +++++++++--
 2 files changed, 17 insertions(+), 2 deletions(-)

diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 0d88d36..c08464b 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -762,10 +762,18 @@ Tcl_UtfAtIndex(
     register int index)		/* The position of the desired character. */
 {
     Tcl_UniChar ch = 0;
+    int len = 1;
 
     while (index-- > 0) {
+	len = TclUtfToUniChar(src, &ch);
+	src += len;
+    }
+#if TCL_UTF_MAX == 4
+     if (!len) {
+	/* Index points at character following High Surrogate */
 	src += TclUtfToUniChar(src, &ch);
     }
+#endif
     return src;
 }
 
diff --git a/tests/string.test b/tests/string.test
index d69fda4..868fc25 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -24,7 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
 
 testConstraint testobj [expr {[info commands testobj] != {}}]
 testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
-testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
+testConstraint tip389 [expr {[string length \U010000] == 2}]
 
 # Used for constraining memory leak tests
 testConstraint memory [llength [info commands memory]]
@@ -291,6 +291,9 @@ test string-5.19 {string index, bytearray object out of bounds} {
 test string-5.20 {string index, bytearray object out of bounds} {
     string index [binary format I* {0x50515253 0x52}] 20
 } {}
+test string-5.21 {string index, surrogates, bug [11ae2be95dac9417]} tip389 {
+    list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]
+} [list \U100000 {} b]
 
 
 proc largest_int {} {
@@ -1280,7 +1283,7 @@ test string-12.22 {string range, shimmering binary/index} {
     binary scan $s a* x
     string range $s $s end
 } 000000001
-test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf {
+test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} tip389 {
     list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]
 } [list \U100000 {} b]
 
@@ -1477,6 +1480,10 @@ test string-17.7 {string totitle, unicode} {
 test string-17.8 {string totitle, compiled} {
     lindex [string totitle [list aa bb [list cc]]] 0
 } Aa
+test string-17.9 {string totitle, surrogates, bug [11ae2be95dac9417]} tip389 {
+    list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \
+	[string totitle a\U118c0c 3 3]
+} [list a\U118a0c a\U118c0C a\U118c0C]
 
 test string-18.1 {string trim} {
     list [catch {string trim} msg] $msg
-- 
cgit v0.12