Tcl Source Code

Check-in [7c614b9330]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:TIP 421 Implementation.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-branch
Files: files | file ages | folders
SHA3-256:7c614b93309da90ae76ced68f3fb5de8a1ce1f381be25c38307377ee116e90b3
User & Date: dgp 2018-04-20 16:02:47
Context
2018-04-22
13:27
merge 8.6 check-in: 143af13340 user: dgp tags: core-8-branch
2018-04-20
16:55
merge 8.7 check-in: 03e1985393 user: dgp tags: trunk
16:02
TIP 421 Implementation. check-in: 7c614b9330 user: dgp tags: core-8-branch
10:16
TIP #389 implementation. check-in: e109760b1c user: jan.nijtmans tags: core-8-branch
2018-04-19
17:46
Adapt [array for] to use the refactored routines. Closed-Leaf check-in: bf63bb7d85 user: dgp tags: tip-421
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/array.n.

43
44
45
46
47
48
49









50
51
52
53
54
55
56
been the return value from a previous invocation of
\fBarray startsearch\fR.  Returns an empty string.
.TP
\fBarray exists \fIarrayName\fR
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 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
and the second element of each pair is the value of the
array element.  The order of the pairs is undefined.
If \fIpattern\fR is not specified, then all of the elements of the
array are included in the result.







>
>
>
>
>
>
>
>
>







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
been the return value from a previous invocation of
\fBarray startsearch\fR.  Returns an empty string.
.TP
\fBarray exists \fIarrayName\fR
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\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
element in each pair is the name of an element in \fIarrayName\fR
and the second element of each pair is the value of the
array element.  The order of the pairs is undefined.
If \fIpattern\fR is not specified, then all of the elements of the
array are included in the result.

Changes to generic/tclVar.c.

162
163
164
165
166
167
168

169
170
171
172
173
174
175
176



177
178
179
180
181
182
183
....
2901
2902
2903
2904
2905
2906
2907













































































































































































































































































































2908
2909
2910
2911
2912
2913
2914
....
2969
2970
2971
2972
2973
2974
2975












































2976
2977
2978
2979
2980
2981
2982
....
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
....
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213

3214
3215
3216
3217
3218
3219
3220
....
4036
4037
4038
4039
4040
4041
4042

4043
4044
4045
4046
4047
4048
4049
				 * Tcl_FirstHashEntry call or from an "array
				 * anymore" command). NULL means must call
				 * Tcl_NextHashEntry to get value to
				 * return. */
    struct ArraySearch *nextPtr;/* Next in list of all active searches for
				 * this variable, or NULL if this is the last
				 * one. */

} ArraySearch;

/*
 * Forward references to functions defined later in this file:
 */

static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *patternPtr, int includeLinks);



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, int *isArrayPtr);
static int		NotArrayError(Tcl_Interp *interp, Tcl_Obj *name);
static Tcl_Var		ObjFindNamespaceVar(Tcl_Interp *interp,
................................................................................
    Tcl_SetObjResult(interp, newValuePtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *













































































































































































































































































































 * ArrayStartSearchCmd --
 *
 *	This object-based function is invoked to process the "array
 *	startsearch" Tcl command. See the user documentation for details on
 *	what it does.
 *
 * Results:
................................................................................
	    &searchPtr->search);
    Tcl_SetHashValue(hPtr, searchPtr);
    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1]));
    Tcl_IncrRefCount(searchPtr->name);
    Tcl_SetObjResult(interp, searchPtr->name);
    return TCL_OK;
}












































 
/*
 *----------------------------------------------------------------------
 *
 * ArrayAnyMoreCmd --
 *
 *	This object-based function is invoked to process the "array anymore"
................................................................................
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *varNameObj, *searchObj;
    ArraySearch *searchPtr, *prevPtr;
    int isArray;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
	return TCL_ERROR;
    }
    varNameObj = objv[1];
................................................................................
     */

    searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
    if (searchPtr == NULL) {
	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;
	    }
	}
    }

    Tcl_DecrRefCount(searchPtr->name);
    ckfree(searchPtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
TclInitArrayCmd(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    static const EnsembleImplMap arrayImplMap[] = {
	{"anymore",	ArrayAnyMoreCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"donesearch",	ArrayDoneSearchCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"exists",	ArrayExistsCmd,		TclCompileArrayExistsCmd, NULL, NULL, 0},

	{"get",		ArrayGetCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
	{"names",	ArrayNamesCmd,		TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
	{"nextelement",	ArrayNextElementCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"set",		ArraySetCmd,		TclCompileArraySetCmd, NULL, NULL, 0},
	{"size",	ArraySizeCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"startsearch",	ArrayStartSearchCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"statistics",	ArrayStatsCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},







>








>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<

|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>







 







>







162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
....
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
....
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
....
3506
3507
3508
3509
3510
3511
3512

3513
3514
3515
3516
3517
3518
3519
3520
3521
....
3534
3535
3536
3537
3538
3539
3540





















3541
3542
3543
3544
3545
3546
3547
3548
....
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
				 * Tcl_FirstHashEntry call or from an "array
				 * anymore" command). NULL means must call
				 * Tcl_NextHashEntry to get value to
				 * return. */
    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;

/*
 * Forward references to functions defined later in this file:
 */

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);
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_SetObjResult(interp, newValuePtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * ArrayForObjCmd
 * 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.
 *
 *  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.
 *
 *  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;

    /* 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
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;
}

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,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
    ArraySearch *searchPtr = NULL;
    Var *varPtr;
    int isArray, numVars;

    /*
     * array for {k v} a body
     */

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"{key value} arrayName script");
	return TCL_ERROR;
    }

    /*
     * Parse arguments.
     */

    if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) {
	return TCL_ERROR;
    }

    if (numVars != 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];

    if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
	return TCL_ERROR;
    }

    if (!isArray) {
	return NotArrayError(interp, arrayNameObj);
    }

    /*
     * 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.
     */

    varListObj = TclListObjCopy(NULL, objv[1]);
    scriptObj = objv[3];
    Tcl_IncrRefCount(scriptObj);

    /*
     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    NULL, scriptObj);
    return TCL_OK;
}

static int
ArrayForLoopCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    ArraySearch *searchPtr = data[0];
    Tcl_Obj *varListObj = data[1];
    Tcl_Obj *scriptObj = data[3];
    Tcl_Obj **varv;
    Tcl_Obj *keyObj, *valueObj;
    Var *varPtr;
    Var *arrayPtr;
    int done, varc;

    /*
     * 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) {
	  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;
    }

    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, varv[1], NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
        result = TCL_ERROR;
        goto arrayfordone;
      }
    }

    /*
     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    NULL, 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);
	Tcl_DecrRefCount(searchPtr->name);
      ckfree(searchPtr);
    }

    TclDecrRefCount(varListObj);
    TclDecrRefCount(scriptObj);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * ArrayStartSearchCmd --
 *
 *	This object-based function is invoked to process the "array
 *	startsearch" Tcl command. See the user documentation for details on
 *	what it does.
 *
 * Results:
................................................................................
	    &searchPtr->search);
    Tcl_SetHashValue(hPtr, searchPtr);
    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1]));
    Tcl_IncrRefCount(searchPtr->name);
    Tcl_SetObjResult(interp, searchPtr->name);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * 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"
................................................................................
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr;

    Tcl_Obj *varNameObj, *searchObj;
    ArraySearch *searchPtr;
    int isArray;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
	return TCL_ERROR;
    }
    varNameObj = objv[1];
................................................................................
     */

    searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
    if (searchPtr == NULL) {
	return TCL_ERROR;
    }






















    ArrayDoneSearch (iPtr, varPtr, searchPtr);
    Tcl_DecrRefCount(searchPtr->name);
    ckfree(searchPtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
TclInitArrayCmd(
    Tcl_Interp *interp)		/* Current interpreter. */
{
    static const EnsembleImplMap arrayImplMap[] = {
	{"anymore",	ArrayAnyMoreCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"donesearch",	ArrayDoneSearchCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
	{"exists",	ArrayExistsCmd,		TclCompileArrayExistsCmd, NULL, 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},
	{"set",		ArraySetCmd,		TclCompileArraySetCmd, NULL, NULL, 0},
	{"size",	ArraySizeCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"startsearch",	ArrayStartSearchCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
	{"statistics",	ArrayStatsCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},

Changes to tests/set-old.test.

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    }
    foo
} {1 {"x" isn't an array}}
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}}
test set-old-8.7 {array command, anymore option} {
    catch {unset a}
    list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
    proc foo {x} {
        if {$x==1} {







|







336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
    }
    foo
} {1 {"x" isn't an array}}
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, 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
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
    proc foo {x} {
        if {$x==1} {

Changes to tests/var.test.

1026
1027
1028
1029
1030
1031
1032
1033



























































































































































1034
1035
1036
1037
1038
1039
1040
} -result 0
test var-22.2 {leak in parsedVarName} -constraints memory -body {
    set i 0
    leaktest {lappend x($i)}
} -cleanup {
    unset -nocomplain i x
} -result 0




























































































































































 
catch {namespace delete ns}
catch {unset arr}
catch {unset v}

catch {rename getbytes ""}
catch {rename p ""}







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
} -result 0
test var-22.2 {leak in parsedVarName} -constraints memory -body {
    set i 0
    leaktest {lappend x($i)}
} -cleanup {
    unset -nocomplain i x
} -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
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}
catch {unset v}

catch {rename getbytes ""}
catch {rename p ""}