diff --git a/generic/tclVar.c b/generic/tclVar.c index 48e09f620f6d..f162d7620ab6 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -155,6 +155,9 @@ typedef struct ArraySearch { * array. */ struct Var *varPtr; /* Pointer to array variable that's being * searched. */ + Tcl_Obj *arrayNameObj; /* Name of the array variable in the current + * resolution context. Usually NULL except for + * in "array for". */ Tcl_HashSearch search; /* Info kept by the hash module about progress * through the array. */ Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to @@ -174,6 +177,7 @@ typedef struct ArraySearch { static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks); +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); @@ -2828,6 +2832,260 @@ TclArraySet( return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * ArrayForNRCmd -- + * + * These functions implement the "array for" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +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 *varNameObj; + ArraySearch *searchPtr = NULL; + Var *varPtr; + Var *arrayPtr; + int varc; + + /* + * array for {k} a body + * array for {k v} a body + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "{keyVarName ?valueVarName?} array script"); + return TCL_ERROR; + } + + /* + * Parse arguments. + */ + + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + return TCL_ERROR; + } + if (varc < 1 || varc > 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have one or two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); + return TCL_ERROR; + } + + varNameObj = objv[2]; + keyVarObj = varv[0]; + valueVarObj = (varc < 2 ? NULL : varv[1]); + scriptObj = objv[3]; + + /* + * Locate the array variable. + */ + + 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; + } + } + + /* + * 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(varNameObj); + + 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 = TclStackAlloc(interp, sizeof(ArraySearch)); + searchPtr->id = 1; + + /* + * Do not turn on VAR_SEARCH_ACTIVE in varPtr->flags. This search is not + * stored in the search list. + */ + + searchPtr->nextPtr = NULL; + searchPtr->varPtr = varPtr; + searchPtr->arrayNameObj = varNameObj; + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); + + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. + */ + + Tcl_IncrRefCount(keyVarObj); + if (valueVarObj != NULL) { + Tcl_IncrRefCount(valueVarObj); + } + Tcl_IncrRefCount(scriptObj); + Tcl_IncrRefCount(varNameObj); + + /* + * 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 *arrayNameObj = searchPtr->arrayNameObj; + Tcl_Obj *keyObj; + Tcl_Obj *valueObj = NULL; + Var *varPtr; + int gotValue; + + /* + * Process the result from the previous execution of the script body. + */ + + 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 done; + } + + /* + * Get the next mapping from the array. + */ + + while (1) { + Tcl_HashEntry *hPtr = searchPtr->nextEntry; + + /* + * The only time hPtr will be non-NULL is when first started. + * nextEntry is set by the Tcl_FirstHashEntry call in the + * ArrayForNRCmd + */ + + if (hPtr != NULL) { + searchPtr->nextEntry = NULL; + varPtr = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr)) { + gotValue = 1; + break; + } + } + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + gotValue = 0; + break; + } + } + varPtr = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr)) { + gotValue = 1; + break; + } + } + + if (!gotValue) { + Tcl_ResetResult(interp); + goto done; + } + + keyObj = VarHashGetKey(varPtr); + if (valueVarObj != NULL) { + valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj, + TCL_LEAVE_ERR_MSG); + } + + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto done; + } + if (valueVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto done; + } + } + + /* + * 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. + */ + + done: + TclDecrRefCount(keyVarObj); + if (valueVarObj != NULL) { + TclDecrRefCount(valueVarObj); + } + TclDecrRefCount(scriptObj); + TclDecrRefCount(arrayNameObj); + TclStackFree(interp, searchPtr); + return result; +} + /* *---------------------------------------------------------------------- * @@ -2932,6 +3190,7 @@ ArrayStartSearchCmd( searchPtr->nextPtr = Tcl_GetHashValue(hPtr); } searchPtr->varPtr = varPtr; + searchPtr->arrayNameObj = NULL; searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, &searchPtr->search); Tcl_SetHashValue(hPtr, searchPtr); @@ -4026,6 +4285,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 93169f10d203..3b0d48b88789 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 diff --git a/tests/var.test b/tests/var.test index 9816d98211f2..d81767a99fa7 100644 --- a/tests/var.test +++ b/tests/var.test @@ -997,6 +997,81 @@ test var-22.2 {leak in parsedVarName} -constraints memory -body { unset -nocomplain i x } -result 0 +unset -nocomplain a k v +test var-23.1 {array command, for loop} -returnCodes error -body { + array for {k v} c d e {} +} -result {wrong # args: should be "array for {keyVarName ?valueVarName?} array script"} +test var-23.2 {array command, for loop} -returnCodes error -body { + array for d {} +} -result {wrong # args: should be "array for {keyVarName ?valueVarName?} array script"} +test var-23.3 {array command, for loop, wrong # of list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v w} a {} +} -result {must have one or two variable names} +test var-23.4 {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.5 {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.6 {array enumeration} -setup { + catch {unset a} + catch {unset reslist} + catch {unset res} + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + } + # if someone turns on varPtr->flags |= VAR_SEARCH_ACTIVE + # a segmentation violation will result. + unset a; # this should not cause a segmentation violation. + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a +} -result {a 1 b 2 c 3} +test var-23.7 {array enumeration, without value} -setup { + catch {unset a} + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k} a { + lappend reslist $k + } + # there is no guarantee in which order the array contents will be + # returned. + lsort $reslist +} -result {a b c} +test var-23.8 {array enumeration, nested} -setup { + catch {unset 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 +} -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}} catch {namespace delete ns} catch {unset arr}