Skip to content

Commit

Permalink
Implementation of [array for] from Brad Lanam. See flightaware/Tcl-bo…
Browse files Browse the repository at this point in the history 
…unties#12 for details.

FossilOrigin-Name: bd05353216cc56ffc17f11dc0ad6c5f3fde79536
  • Loading branch information
dkf committed Nov 24, 2016
1 parent 691fe50 commit 6588754
Show file tree
Hide file tree
Showing 3 changed files with 336 additions and 1 deletion.
260 changes: 260 additions & 0 deletions generic/tclVar.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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);
Expand Down Expand Up @@ -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;
}

/*
*----------------------------------------------------------------------
*
Expand Down Expand Up @@ -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);
Expand Down Expand Up @@ -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},
Expand Down
2 changes: 1 addition & 1 deletion tests/set-old.test
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
75 changes: 75 additions & 0 deletions tests/var.test
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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}
Expand Down

0 comments on commit 6588754

Please sign in to comment.