Tcl Source Code

Check-in [d18e291b03]
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:Satisfy test var-23.14
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-421
Files: files | file ages | folders
SHA3-256:d18e291b03d34f22324f2d0fecbcc40c272338a0cd5be3b289e6a09c6a0ad907
User & Date: dgp 2018-04-17 11:11:35
Context
2018-04-19
17:40
merge 8.7 check-in: 247df44614 user: dgp tags: tip-421
2018-04-17
11:11
Satisfy test var-23.14 check-in: d18e291b03 user: dgp tags: tip-421
03:48
Test of shimmer segfault. check-in: d7d48d477c user: dgp tags: tip-421
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclVar.c.

3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
....
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
....
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
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
....
3329
3330
3331
3332
3333
3334
3335


3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
....
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
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,
................................................................................
	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);
................................................................................
    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,
................................................................................
	      "array changed during iteration", -1));
	  Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
	  varPtr->flags |= TCL_LEAVE_ERR_MSG;
          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 (done != TCL_ERROR) {
      ArrayDoneSearch (iPtr, varPtr, searchPtr);
	Tcl_DecrRefCount(searchPtr->name);
      ckfree(searchPtr);
    }

    TclDecrRefCount(keyVarObj);
    TclDecrRefCount(valueVarObj);
    TclDecrRefCount(scriptObj);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *







|
<
<



|







 







<
>
>


>
|







<
<
<







 







|
|






|
|











|
|
|



|







 







>
>
|




|









|
|







 







<
|







3171
3172
3173
3174
3175
3176
3177
3178


3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
....
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
....
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
....
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
....
3361
3362
3363
3364
3365
3366
3367

3368
3369
3370
3371
3372
3373
3374
3375
ArrayForNRCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;


    ArraySearch *searchPtr = NULL;
    Var *varPtr;
    Var *arrayPtr;
    int numVars;

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

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
................................................................................
	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];




    /*
     * Locate the array variable.
     */

    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
................................................................................
    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,
................................................................................
	      "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 (done != TCL_ERROR) {
      ArrayDoneSearch (iPtr, varPtr, searchPtr);
	Tcl_DecrRefCount(searchPtr->name);
      ckfree(searchPtr);
    }


    TclDecrRefCount(varListObj);
    TclDecrRefCount(scriptObj);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *