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 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 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