Tcl Source Code

Check-in [582877d8ab]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:[2835313] Ensure correct stack balance when break and continue exceptions are about: the hard cases with potential concealed exception generation.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 582877d8ab09712c2ea3fb93aa2857059877535d
User & Date: dkf 2013-10-20 18:15:08
Context
2013-10-21
14:35
silence compiler warnings check-in: 14351c91dd user: dgp tags: trunk
2013-10-20
18:44
merge trunk check-in: cddba18029 user: dkf tags: dkf-bytecode-8.6-main
18:15
[2835313] Ensure correct stack balance when break and continue exceptions are about: the hard cases ... check-in: 582877d8ab user: dkf tags: trunk
18:11
And the last bits that need fixing; the code is still less efficient than desired but should now not... Closed-Leaf check-in: bd1fb54305 user: dkf tags: dkf-loop-exception-range-work
2013-10-17
09:40
Fix execute permission on many files which shouldn't have it. check-in: e9c8ef1fe6 user: jan.nijtmans tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclAssembly.c.

242
243
244
245
246
247
248


249
250
251
252
253
254
255
...
675
676
677
678
679
680
681
682
683
684
685



686
687
688
689
690
691
692
...
707
708
709
710
711
712
713























714
715
716
717
718
719
720
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
			    int count);
static void		BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int param, int count);


static void		BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int count);
static int		BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int		CalculateJumpRelocations(AssemblyEnv*, int*);
static int		CheckForUnclosedCatches(AssemblyEnv*);
static int		CheckForThrowInWrongContext(AssemblyEnv*);
static int		CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
................................................................................
    BBEmitOpcode(assemEnvPtr, tblIdx, count);
    TclEmitInt4(opnd, assemEnvPtr->envPtr);
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * BBEmitInst1or4 --
 *
 *	Emits a 1- or 4-byte operation according to the magnitude of the
 *	operand



 *
 *-----------------------------------------------------------------------------
 */

static void
BBEmitInst1or4(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
................................................................................
    }
    TclEmitInt1(op, envPtr);
    if (param <= 0xff) {
	TclEmitInt1(param, envPtr);
    } else {
	TclEmitInt4(param, envPtr);
    }























    TclUpdateAtCmdStart(op, envPtr);
    BBUpdateStackReqs(bbPtr, tblIdx, count);
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}

	BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_JUMP:
    case ASSEM_JUMP4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
	    goto cleanup;






>
>







 







|


|
>
>
>







 







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







 







|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
...
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
...
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
....
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
			    int count);
static void		BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int opnd, int count);
static void		BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int param, int count);
static void		BBEmitInvoke1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int param, int count);
static void		BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int count);
static int		BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int		CalculateJumpRelocations(AssemblyEnv*, int*);
static int		CheckForUnclosedCatches(AssemblyEnv*);
static int		CheckForThrowInWrongContext(AssemblyEnv*);
static int		CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
................................................................................
    BBEmitOpcode(assemEnvPtr, tblIdx, count);
    TclEmitInt4(opnd, assemEnvPtr->envPtr);
}
 
/*
 *-----------------------------------------------------------------------------
 *
 * BBEmitInst1or4, BBEmitInvoke1or4 --
 *
 *	Emits a 1- or 4-byte operation according to the magnitude of the
 *	operand. The Invoke variant generates wrapping stack-balance
 *	management if necessary (which is not normally required in assembled
 *	code, as loop exception ranges, expansions, breaks and continues can't
 *	be issued currently).
 *
 *-----------------------------------------------------------------------------
 */

static void
BBEmitInst1or4(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
................................................................................
    }
    TclEmitInt1(op, envPtr);
    if (param <= 0xff) {
	TclEmitInt1(param, envPtr);
    } else {
	TclEmitInt4(param, envPtr);
    }
    TclUpdateAtCmdStart(op, envPtr);
    BBUpdateStackReqs(bbPtr, tblIdx, count);
}

static void
BBEmitInvoke1or4(
    AssemblyEnv* assemEnvPtr,	/* Assembly environment */
    int tblIdx,			/* Index in TalInstructionTable of op */
    int param,			/* Variable-length parameter */
    int count)			/* Arity if variadic */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */
    int op = TalInstructionTable[tblIdx].tclInstCode;

    if (param <= 0xff) {
	op >>= 8;
    } else {
	op &= 0xff;
    }
    TclEmitInvoke(envPtr, op, param);
    TclUpdateAtCmdStart(op, envPtr);
    BBUpdateStackReqs(bbPtr, tblIdx, count);
}
 
/*
 *-----------------------------------------------------------------------------
 *
................................................................................
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}

	BBEmitInvoke1or4(assemEnvPtr, tblIdx, opnd, opnd);
	break;

    case ASSEM_JUMP:
    case ASSEM_JUMP4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
	    goto cleanup;

Changes to generic/tclCompCmds.c.

265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
...
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
...
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
....
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
....
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
....
2131
2132
2133
2134
2135
2136
2137
2138
2139

2140
2141
2142
2143
2144
2145





2146

2147





2148



2149
2150
















2151
2152
2153
2154
2155
2156
2157
    /*
     * Special case: literal odd-length argument is always an error.
     */

    if (isDataValid && !isDataEven) {
	PushStringLiteral(envPtr, "list must have an even number of elements");
	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
	TclEmitInstInt4(INST_RETURN_IMM, 1,			envPtr);
	TclEmitInt4(		0,				envPtr);
	goto done;
    }

    /*
     * Except for the special "ensure array" case below, when we're not in
     * a proc, we cannot do a better compile than generic.
................................................................................
	TclEmitOpcode(	INST_LIST_LENGTH,			envPtr);
	PushStringLiteral(envPtr, "1");
	TclEmitOpcode(	INST_BITAND,				envPtr);
	offsetFwd = CurrentOffset(envPtr);
	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
	PushStringLiteral(envPtr, "list must have an even number of elements");
	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
	TclEmitInstInt4(INST_RETURN_IMM, 1,			envPtr);
	TclEmitInt4(		0,				envPtr);
	TclAdjustStackDepth(-1, envPtr);
	fwd = CurrentOffset(envPtr) - offsetFwd;
	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
    }
    Emit14Inst(		INST_STORE_SCALAR, dataVar,		envPtr);
    TclEmitOpcode(	INST_POP,				envPtr);
................................................................................
	BODY(cmdTokenPtr, 1);
    } else {
	SetLineInformation(1);
	CompileTokens(envPtr, cmdTokenPtr, interp);
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	TclEmitOpcode(		INST_DUP,			envPtr);
	TclEmitOpcode(		INST_EVAL_STK,			envPtr);
    }
    /* Stack at this point:
     *    nonsimple:  script <mark> result
     *    simple:            <mark> result
     */

    if (resultIndex == -1) {
................................................................................
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);
    TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);

    TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
    TclEmitInt4(		infoIndex,			envPtr);
    TclEmitOpcode(	INST_RETURN_STK,			envPtr);

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
    }
    TclStackFree(interp, keyTokenPtrs);
    return TCL_OK;
................................................................................
    }
    Emit14Inst(			INST_LOAD_SCALAR, keysTmp,	envPtr);
    if (dictVar == -1) {
	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
    } else {
	TclEmitInstInt4(	INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
    }
    TclEmitOpcode(		INST_RETURN_STK,		envPtr);

    /*
     * Prepare for the start of the next command.
     */

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
................................................................................
				 * created by Tcl_ParseCommand. */
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    /*
     * General syntax: [error message ?errorInfo? ?errorCode?]
     * However, we only deal with the case where there is just a message.
     */

    Tcl_Token *messageTokenPtr;
    DefineLineInformation;	/* TIP #280 */

    if (parsePtr->numWords != 2) {
	return TCL_ERROR;
    }





    messageTokenPtr = TokenAfter(parsePtr->tokenPtr);







    PushStringLiteral(envPtr, "-code error -level 0");



    CompileWord(envPtr, messageTokenPtr, interp, 1);
    TclEmitOpcode(INST_RETURN_STK, envPtr);
















    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileExprCmd --






|







 







|







 







|







 







|







 







|







 







<

>
|


|


>
>
>
>
>
|
>

>
>
>
>
>
|
>
>
>
|
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
...
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
...
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
....
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
....
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
....
2131
2132
2133
2134
2135
2136
2137

2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163

2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
    /*
     * Special case: literal odd-length argument is always an error.
     */

    if (isDataValid && !isDataEven) {
	PushStringLiteral(envPtr, "list must have an even number of elements");
	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
	TclEmitInt4(		0,				envPtr);
	goto done;
    }

    /*
     * Except for the special "ensure array" case below, when we're not in
     * a proc, we cannot do a better compile than generic.
................................................................................
	TclEmitOpcode(	INST_LIST_LENGTH,			envPtr);
	PushStringLiteral(envPtr, "1");
	TclEmitOpcode(	INST_BITAND,				envPtr);
	offsetFwd = CurrentOffset(envPtr);
	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
	PushStringLiteral(envPtr, "list must have an even number of elements");
	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
	TclEmitInt4(		0,				envPtr);
	TclAdjustStackDepth(-1, envPtr);
	fwd = CurrentOffset(envPtr) - offsetFwd;
	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
    }
    Emit14Inst(		INST_STORE_SCALAR, dataVar,		envPtr);
    TclEmitOpcode(	INST_POP,				envPtr);
................................................................................
	BODY(cmdTokenPtr, 1);
    } else {
	SetLineInformation(1);
	CompileTokens(envPtr, cmdTokenPtr, interp);
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	TclEmitOpcode(		INST_DUP,			envPtr);
	TclEmitInvoke(envPtr,	INST_EVAL_STK);
    }
    /* Stack at this point:
     *    nonsimple:  script <mark> result
     *    simple:            <mark> result
     */

    if (resultIndex == -1) {
................................................................................
    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
    TclEmitOpcode(	INST_END_CATCH,				envPtr);
    TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);

    TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
    TclEmitInt4(		infoIndex,			envPtr);
    TclEmitInvoke(envPtr,INST_RETURN_STK);

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
    }
    TclStackFree(interp, keyTokenPtrs);
    return TCL_OK;
................................................................................
    }
    Emit14Inst(			INST_LOAD_SCALAR, keysTmp,	envPtr);
    if (dictVar == -1) {
	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
    } else {
	TclEmitInstInt4(	INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
    }
    TclEmitInvoke(envPtr,	INST_RETURN_STK);

    /*
     * Prepare for the start of the next command.
     */

    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
................................................................................
				 * created by Tcl_ParseCommand. */
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    /*
     * General syntax: [error message ?errorInfo? ?errorCode?]

     */

    Tcl_Token *tokenPtr;
    DefineLineInformation;	/* TIP #280 */

    if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
	return TCL_ERROR;
    }

    /*
     * Handle the message.
     */

    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    CompileWord(envPtr, tokenPtr, interp, 1);

    /*
     * Construct the options. Note that -code and -level are not here.
     */

    if (parsePtr->numWords == 2) {
	PushStringLiteral(envPtr, "");
    } else {
	PushStringLiteral(envPtr, "-errorinfo");
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 2);

	if (parsePtr->numWords == 3) {
	    TclEmitInstInt4(	INST_LIST, 2,			envPtr);
	} else {
	    PushStringLiteral(envPtr, "-errorcode");
	    tokenPtr = TokenAfter(tokenPtr);
	    CompileWord(envPtr, tokenPtr, interp, 3);
	    TclEmitInstInt4(	INST_LIST, 4,			envPtr);
	}
    }

    /*
     * Issue the error via 'returnImm error 0'.
     */

    TclEmitInstInt4(		INST_RETURN_IMM, TCL_ERROR,	envPtr);
    TclEmitInt4(			0,			envPtr);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileExprCmd --

Changes to generic/tclCompCmdsGR.c.

2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383




2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
....
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523

















2524
2525
2526
2527
2528
2529
2530
	    && (wordTokenPtr[1].size == 8)
	    && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
	Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
	Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);

	CompileWord(envPtr, optsTokenPtr, interp, 2);
	CompileWord(envPtr, msgTokenPtr,  interp, 3);
	TclEmitOpcode(INST_RETURN_STK, envPtr);
	return TCL_OK;
    }

    /*
     * Allocate some working space.
     */

    objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));

    /*
     * Scan through the return options. If any are unknown at compile time,
     * there is no value in bytecompiling. Save the option values known in an
     * objv array for merging into a return options dictionary.




     */

    for (objc = 0; objc < numOptionWords; objc++) {
	objv[objc] = Tcl_NewObj();
	Tcl_IncrRefCount(objv[objc]);
	if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
	    /*
	     * Non-literal, so punt to run-time.
	     */

	    for (; objc>=0 ; objc--) {
		TclDecrRefCount(objv[objc]);
	    }
	    TclStackFree(interp, objv);
	    goto issueRuntimeReturn;
................................................................................
	PushStringLiteral(envPtr, "");
    }

    /*
     * Issue the RETURN itself.
     */

    TclEmitOpcode(INST_RETURN_STK, envPtr);
    return TCL_OK;
}

static void
CompileReturnInternal(
    CompileEnv *envPtr,
    unsigned char op,
    int code,
    int level,
    Tcl_Obj *returnOpts)
{

















    TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
    TclEmitInstInt4(op, code, envPtr);
    TclEmitInt4(level, envPtr);
}

void
TclCompileSyntaxError(






|













>
>
>
>







|







 







|











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







2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
....
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
	    && (wordTokenPtr[1].size == 8)
	    && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
	Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
	Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);

	CompileWord(envPtr, optsTokenPtr, interp, 2);
	CompileWord(envPtr, msgTokenPtr,  interp, 3);
	TclEmitInvoke(envPtr, INST_RETURN_STK);
	return TCL_OK;
    }

    /*
     * Allocate some working space.
     */

    objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));

    /*
     * Scan through the return options. If any are unknown at compile time,
     * there is no value in bytecompiling. Save the option values known in an
     * objv array for merging into a return options dictionary.
     *
     * TODO: There is potential for improvement if all option keys are known
     * at compile time and all option values relating to '-code' and '-level'
     * are known at compile time.
     */

    for (objc = 0; objc < numOptionWords; objc++) {
	objv[objc] = Tcl_NewObj();
	Tcl_IncrRefCount(objv[objc]);
	if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
	    /*
	     * Non-literal, so punt to run-time assembly of the dictionary.
	     */

	    for (; objc>=0 ; objc--) {
		TclDecrRefCount(objv[objc]);
	    }
	    TclStackFree(interp, objv);
	    goto issueRuntimeReturn;
................................................................................
	PushStringLiteral(envPtr, "");
    }

    /*
     * Issue the RETURN itself.
     */

    TclEmitInvoke(envPtr, INST_RETURN_STK);
    return TCL_OK;
}

static void
CompileReturnInternal(
    CompileEnv *envPtr,
    unsigned char op,
    int code,
    int level,
    Tcl_Obj *returnOpts)
{
    if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) {
	ExceptionRange *rangePtr;
	ExceptionAux *exceptAux;

	rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux);
	if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
	    TclCleanupStackForBreakContinue(envPtr, exceptAux);
	    if (code == TCL_BREAK) {
		TclAddLoopBreakFixup(envPtr, exceptAux);
	    } else {
		TclAddLoopContinueFixup(envPtr, exceptAux);
	    }
	    Tcl_DecrRefCount(returnOpts);
	    return;
	}
    }

    TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
    TclEmitInstInt4(op, code, envPtr);
    TclEmitInt4(level, envPtr);
}

void
TclCompileSyntaxError(

Changes to generic/tclCompCmdsSZ.c.

95
96
97
98
99
100
101


102
103
104
105
106
107
108
...
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
....
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
....
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
....
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
....
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
....
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
    (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
#define FIXJUMP1(var) \
    TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
    if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
    if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}


 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileSetCmd --
 *
 *	Procedure called to compile the "set" command.
................................................................................
	ExceptionRangeTarget(envPtr, catchRange, catchOffset);
	OP(	PUSH_RETURN_OPTIONS);
	OP(	PUSH_RESULT);
	OP(	PUSH_RETURN_CODE);
	OP(	END_CATCH);
	OP(	RETURN_CODE_BRANCH);

	/* ERROR -> reraise it */
	OP(	RETURN_STK);
	OP(	NOP);

	/* RETURN */
	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);

	/* BREAK */
................................................................................
	 * run time.
	 */
	OP4(			REVERSE, 3);
	OP(			DUP);
	OP(			LIST_LENGTH);
	OP1(			JUMP_FALSE1, 16);
	OP4(			LIST, 2);
	OP44(			RETURN_IMM, 1, 0);
	TclAdjustStackDepth(2, envPtr);
	OP(			POP);
	OP(			POP);
	OP(			POP);
    issueErrorForEmptyCode:
	PUSH(			"type must be non-empty list");
	PUSH(			"-errorcode {TCL OPERATION THROW BADEXCEPTION}");
    }
    OP44(			RETURN_IMM, 1, 0);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileTryCmd --
................................................................................
	    OP(				POP);
	    PUSH(			"-during");
	    OP4(			REVERSE, 2);
	    OP44(			DICT_SET, 1, optionsVar);
	    TclAdjustStackDepth(-1, envPtr);
	    FIXJUMP1(		dontChangeOptions);
	    OP4(			REVERSE, 2);
	    OP(				RETURN_STK);
	}

	JUMP4(				JUMP, addrsToFix[i]);
	if (matchClauses[i]) {
	    FIXJUMP4(	notECJumpSource);
	}
	FIXJUMP4(	notCodeJumpSource);
................................................................................
     * exception. Note also that INST_RETURN_STK can proceed to the next
     * instruction.
     */

    OP(					POP);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    OP(					RETURN_STK);

    /*
     * Fix all the jumps from taken clauses to here (which is the end of the
     * [try]).
     */

    if (!trapZero) {
................................................................................
    OP(					POP);
    FIXJUMP1(			finalError);
    STORE(				resultVar);
    OP(					POP);
    FIXJUMP1(			finalOK);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    OP(					RETURN_STK);

    return TCL_OK;
}

static int
IssueTryFinallyInstructions(
    Tcl_Interp *interp,
................................................................................
    FIXJUMP1(		jumpSplice);
    OP4(				REVERSE, 4);
    OP(					POP);
    OP(					POP);
    OP1(				JUMP1, 7);
    FIXJUMP1(		jumpOK);
    OP4(				REVERSE, 2);
    OP(					RETURN_STK);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileUnsetCmd --






>
>







 







|







 







|








|







 







|







 







|







 







|







 







|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
...
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
....
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
....
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
....
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
....
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
....
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
    (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
#define FIXJUMP1(var) \
    TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
    if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
    if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
#define INVOKE(name) \
    TclEmitInvoke(envPtr,INST_##name)
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileSetCmd --
 *
 *	Procedure called to compile the "set" command.
................................................................................
	ExceptionRangeTarget(envPtr, catchRange, catchOffset);
	OP(	PUSH_RETURN_OPTIONS);
	OP(	PUSH_RESULT);
	OP(	PUSH_RETURN_CODE);
	OP(	END_CATCH);
	OP(	RETURN_CODE_BRANCH);

	/* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */
	OP(	RETURN_STK);
	OP(	NOP);

	/* RETURN */
	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);

	/* BREAK */
................................................................................
	 * run time.
	 */
	OP4(			REVERSE, 3);
	OP(			DUP);
	OP(			LIST_LENGTH);
	OP1(			JUMP_FALSE1, 16);
	OP4(			LIST, 2);
	OP44(			RETURN_IMM, TCL_ERROR, 0);
	TclAdjustStackDepth(2, envPtr);
	OP(			POP);
	OP(			POP);
	OP(			POP);
    issueErrorForEmptyCode:
	PUSH(			"type must be non-empty list");
	PUSH(			"-errorcode {TCL OPERATION THROW BADEXCEPTION}");
    }
    OP44(			RETURN_IMM, TCL_ERROR, 0);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileTryCmd --
................................................................................
	    OP(				POP);
	    PUSH(			"-during");
	    OP4(			REVERSE, 2);
	    OP44(			DICT_SET, 1, optionsVar);
	    TclAdjustStackDepth(-1, envPtr);
	    FIXJUMP1(		dontChangeOptions);
	    OP4(			REVERSE, 2);
	    INVOKE(			RETURN_STK);
	}

	JUMP4(				JUMP, addrsToFix[i]);
	if (matchClauses[i]) {
	    FIXJUMP4(	notECJumpSource);
	}
	FIXJUMP4(	notCodeJumpSource);
................................................................................
     * exception. Note also that INST_RETURN_STK can proceed to the next
     * instruction.
     */

    OP(					POP);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    INVOKE(				RETURN_STK);

    /*
     * Fix all the jumps from taken clauses to here (which is the end of the
     * [try]).
     */

    if (!trapZero) {
................................................................................
    OP(					POP);
    FIXJUMP1(			finalError);
    STORE(				resultVar);
    OP(					POP);
    FIXJUMP1(			finalOK);
    LOAD(				optionsVar);
    LOAD(				resultVar);
    INVOKE(				RETURN_STK);

    return TCL_OK;
}

static int
IssueTryFinallyInstructions(
    Tcl_Interp *interp,
................................................................................
    FIXJUMP1(		jumpSplice);
    OP4(				REVERSE, 4);
    OP(					POP);
    OP(					POP);
    OP1(				JUMP1, 7);
    FIXJUMP1(		jumpOK);
    OP4(				REVERSE, 2);
    INVOKE(				RETURN_STK);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileUnsetCmd --

Changes to generic/tclCompExpr.c.

2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
	    case FUNCTION:
		/*
		 * Use the numWords count we've kept to invoke the function
		 * command with the correct number of arguments.
		 */
		
		if (numWords < 255) {
		    TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr);
		} else {
		    TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr);
		}

		/*
		 * Restore any saved numWords value.
		 */

		numWords = nodePtr->left;






|

|







2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
	    case FUNCTION:
		/*
		 * Use the numWords count we've kept to invoke the function
		 * command with the correct number of arguments.
		 */
		
		if (numWords < 255) {
		    TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords);
		} else {
		    TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords);
		}

		/*
		 * Restore any saved numWords value.
		 */

		numWords = nodePtr->left;

Changes to generic/tclCompile.c.

1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
....
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
....
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
....
3896
3897
3898
3899
3900
3901
3902
































































































































































































3903
3904
3905
3906
3907
3908
3909
	    TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
		    tokenPtr[1].start - envPtr->source, envPtr->clNext);
	}
	TclEmitPush(objIdx, envPtr);
    }

    if (wordIdx <= 255) {
	TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
    } else {
	TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
    }
}

static void
CompileExpanded(
    Tcl_Interp *interp,
    Tcl_Token *tokenPtr,
................................................................................
     * result is pushed: the stack top changes by (1-wordIdx).
     *
     * Note that the estimates are not correct while the command
     * is being prepared and run, INST_EXPAND_STKTOP is not
     * stack-neutral in general.
     */

    TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
    envPtr->expandCount--;
    TclAdjustStackDepth(1 - wordIdx, envPtr);
}

static int 
CompileCmdCompileProc(
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    Command *cmdPtr,
................................................................................
	/*
	 * Multiple tokens or the single token involves substitutions. Emit
	 * instructions to invoke the eval command procedure at runtime on the
	 * result of evaluating the tokens.
	 */

	TclCompileTokens(interp, tokenPtr, count, envPtr);
	TclEmitOpcode(INST_EVAL_STK, envPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileExprWords --
................................................................................
		auxPtr->continueTargets[i] += 3;
	    }
	}
    }

    return 1;			/* the jump was grown */
}
































































































































































































 
/*
 *----------------------------------------------------------------------
 *
 * TclGetInstructionTable --
 *
 *	Returns a pointer to the table describing Tcl bytecode instructions.






|

|







 







|
<
<







 







|







 







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







1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
....
1798
1799
1800
1801
1802
1803
1804
1805


1806
1807
1808
1809
1810
1811
1812
....
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
....
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
	    TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
		    tokenPtr[1].start - envPtr->source, envPtr->clNext);
	}
	TclEmitPush(objIdx, envPtr);
    }

    if (wordIdx <= 255) {
	TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx);
    } else {
	TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx);
    }
}

static void
CompileExpanded(
    Tcl_Interp *interp,
    Tcl_Token *tokenPtr,
................................................................................
     * result is pushed: the stack top changes by (1-wordIdx).
     *
     * Note that the estimates are not correct while the command
     * is being prepared and run, INST_EXPAND_STKTOP is not
     * stack-neutral in general.
     */

    TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx);


}

static int 
CompileCmdCompileProc(
    Tcl_Interp *interp,
    Tcl_Parse *parsePtr,
    Command *cmdPtr,
................................................................................
	/*
	 * Multiple tokens or the single token involves substitutions. Emit
	 * instructions to invoke the eval command procedure at runtime on the
	 * result of evaluating the tokens.
	 */

	TclCompileTokens(interp, tokenPtr, count, envPtr);
	TclEmitInvoke(envPtr, INST_EVAL_STK);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileExprWords --
................................................................................
		auxPtr->continueTargets[i] += 3;
	    }
	}
    }

    return 1;			/* the jump was grown */
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclEmitInvoke --
 *
 *	Emit one of the invoke-related instructions, wrapping it if necessary
 *	in code that ensures that any break or continue operation passing
 *	through it gets the stack unwinding correct, converting it into an
 *	internal jump if in an appropriate context.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Issues the jump with all correct stack management. May create another
 *	loop exception range; pointers to ExceptionRange and ExceptionAux
 *	structures should not be held across this call.
 *
 *----------------------------------------------------------------------
 */

void
TclEmitInvoke(
    CompileEnv *envPtr,
    int opcode,
    ...)
{
    va_list argList;
    ExceptionRange *rangePtr;
    ExceptionAux *auxBreakPtr, *auxContinuePtr;
    int arg1, arg2, wordCount = 0, expandCount = 0;
    int loopRange, breakRange, continueRange;

    /*
     * Parse the arguments.
     */

    va_start(argList, opcode);
    switch (opcode) {
    case INST_INVOKE_STK1:
	wordCount = arg1 = va_arg(argList, int);
	arg2 = 0;
	break;
    case INST_INVOKE_STK4:
	wordCount = arg1 = va_arg(argList, int);
	arg2 = 0;
	break;
    case INST_INVOKE_REPLACE:
	arg1 = va_arg(argList, int);
	arg2 = va_arg(argList, int);
	wordCount = arg1 + arg2 - 1;
	break;
    default:
	Tcl_Panic("unexpected opcode");
    case INST_EVAL_STK:
	wordCount = 1;
	arg1 = arg2 = 0;
	break;
    case INST_RETURN_STK:
	wordCount = 2;
	arg1 = arg2 = 0;
	break;
    case INST_INVOKE_EXPANDED:
	wordCount = arg1 = va_arg(argList, int);
	arg2 = 0;
	expandCount = 1;
	break;
    }
    va_end(argList);

    /*
     * Determine if we need to handle break and continue exceptions with a
     * special handling exception range (so that we can correctly unwind the
     * stack).
     *
     * These must be done separately; they can be different (especially for
     * calls from inside a [for] increment clause).
     */

    rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr);
    if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
	auxBreakPtr = NULL;
    } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount
	    && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) {
	auxBreakPtr = NULL;
    } else {
	breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
    }

    rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
	    &auxContinuePtr);
    if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
	auxContinuePtr = NULL;
    } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
	    && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) {
	auxContinuePtr = NULL;
    } else {
	continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
    }

    if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
	loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
	ExceptionRangeStarts(envPtr, loopRange);
    }

    /*
     * Issue the invoke itself.
     */

    switch (opcode) {
    case INST_INVOKE_STK1:
	TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr);
	break;
    case INST_INVOKE_STK4:
	TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr);
	break;
    case INST_INVOKE_EXPANDED:
	TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
	envPtr->expandCount--;
	TclAdjustStackDepth(1 - arg1, envPtr);
	break;
    case INST_EVAL_STK:
	TclEmitOpcode(INST_EVAL_STK, envPtr);
	break;
    case INST_RETURN_STK:
	TclEmitOpcode(INST_RETURN_STK, envPtr);
	break;
    case INST_INVOKE_REPLACE:
	TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr);
	TclEmitInt1(arg2, envPtr);
	TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */
	break;
    }

    /*
     * If we're generating a special wrapper exception range, we need to
     * finish that up now.
     */

    if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
	int savedStackDepth = envPtr->currStackDepth;
	int savedExpandCount = envPtr->expandCount;
	JumpFixup nonTrapFixup;
	ExceptionAux *exceptAux = envPtr->exceptAuxArrayPtr + loopRange;

	if (auxBreakPtr != NULL) {
	    auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange;
	}
	if (auxContinuePtr != NULL) {
	    auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange;
	}

	ExceptionRangeEnds(envPtr, loopRange);
	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup);

	/*
	 * Careful! When generating these stack unwinding sequences, the depth
	 * of stack in the cases where they are taken is not the same as if
	 * the exception is not taken.
	 */

	if (auxBreakPtr != NULL) {
	    TclAdjustStackDepth(-1, envPtr);
	    exceptAux->stackDepth = auxBreakPtr->stackDepth;
	    exceptAux->expandTarget = auxBreakPtr->expandTarget;

	    ExceptionRangeTarget(envPtr, loopRange, breakOffset);
	    TclCleanupStackForBreakContinue(envPtr, exceptAux);
	    TclAddLoopBreakFixup(envPtr, auxBreakPtr);

	    envPtr->currStackDepth = savedStackDepth;
	    envPtr->expandCount = savedExpandCount;
	}

	if (auxContinuePtr != NULL) {
	    TclAdjustStackDepth(-1, envPtr);
	    exceptAux->stackDepth = auxContinuePtr->stackDepth;
	    exceptAux->expandTarget = auxContinuePtr->expandTarget;

	    ExceptionRangeTarget(envPtr, loopRange, continueOffset);
	    TclCleanupStackForBreakContinue(envPtr, exceptAux);
	    TclAddLoopContinueFixup(envPtr, auxContinuePtr);

	    envPtr->currStackDepth = savedStackDepth;
	    envPtr->expandCount = savedExpandCount;
	}

	TclFinalizeLoopExceptionRange(envPtr, loopRange);
	TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetInstructionTable --
 *
 *	Returns a pointer to the table describing Tcl bytecode instructions.

Changes to generic/tclCompile.h.

1017
1018
1019
1020
1021
1022
1023

1024
1025
1026
1027
1028
1029
1030
			    Namespace *nsPtr, int flags,
			    LiteralEntry **globalPtrPtr);
MODULE_SCOPE void	TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void	TclDeleteLiteralTable(Tcl_Interp *interp,
			    LiteralTable *tablePtr);
MODULE_SCOPE void	TclEmitForwardJump(CompileEnv *envPtr,
			    TclJumpType jumpType, JumpFixup *jumpFixupPtr);

MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
			    int catchOnly, ByteCode *codePtr);
MODULE_SCOPE void	TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int	TclNRExecuteByteCode(Tcl_Interp *interp,
			    ByteCode *codePtr);
MODULE_SCOPE Tcl_Obj *	TclFetchLiteral(CompileEnv *envPtr, unsigned int index);
MODULE_SCOPE void	TclFinalizeAuxDataTypeTable(void);






>







1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
			    Namespace *nsPtr, int flags,
			    LiteralEntry **globalPtrPtr);
MODULE_SCOPE void	TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void	TclDeleteLiteralTable(Tcl_Interp *interp,
			    LiteralTable *tablePtr);
MODULE_SCOPE void	TclEmitForwardJump(CompileEnv *envPtr,
			    TclJumpType jumpType, JumpFixup *jumpFixupPtr);
MODULE_SCOPE void	TclEmitInvoke(CompileEnv *envPtr, int opcode, ...);
MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
			    int catchOnly, ByteCode *codePtr);
MODULE_SCOPE void	TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int	TclNRExecuteByteCode(Tcl_Interp *interp,
			    ByteCode *codePtr);
MODULE_SCOPE Tcl_Obj *	TclFetchLiteral(CompileEnv *envPtr, unsigned int index);
MODULE_SCOPE void	TclFinalizeAuxDataTypeTable(void);

Changes to generic/tclEnsemble.c.

3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
    TclEmitPush(cmdLit, envPtr);
    TclDecrRefCount(objPtr);

    /*
     * Do the replacing dispatch.
     */

    TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
    TclEmitInt1(numWords+1, envPtr);
    TclAdjustStackDepth(-1, envPtr);	/* Correction to stack depth calcs. */
}
 
/*
 * Helpers that do issuing of instructions for commands that "don't have
 * compilers" (well, they do; these). They all work by just generating base
 * code to invoke the command; they're intended for ensemble subcommands so
 * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out






|
<
<







3175
3176
3177
3178
3179
3180
3181
3182


3183
3184
3185
3186
3187
3188
3189
    TclEmitPush(cmdLit, envPtr);
    TclDecrRefCount(objPtr);

    /*
     * Do the replacing dispatch.
     */

    TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1);


}
 
/*
 * Helpers that do issuing of instructions for commands that "don't have
 * compilers" (well, they do; these). They all work by just generating base
 * code to invoke the command; they're intended for ensemble subcommands so
 * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out

Changes to generic/tclOptimize.c.

340
341
342
343
344
345
346

347
348
349
350
351
352
353
354
355
356
357

358
359
360





361
362
363
364
365
366
367
...
369
370
371
372
373
374
375

376
377
378
379
380
381


382





383
384
385
386
387
388
389
390
391
392
393
394
395

396
397
398
399
400
401
402
 */

static void
AdvanceJumps(
    CompileEnv *envPtr)
{
    unsigned char *currentInstPtr;


    for (currentInstPtr = envPtr->codeStart ;
	    currentInstPtr < envPtr->codeNext-1 ;
	    currentInstPtr += AddrLength(currentInstPtr)) {
	int offset, delta;

	switch (*currentInstPtr) {
	case INST_JUMP1:
	case INST_JUMP_TRUE1:
	case INST_JUMP_FALSE1:
	    offset = TclGetInt1AtPtr(currentInstPtr + 1);

	    for (delta=0 ; offset+delta != 0 ;) {
		if (offset + delta < -128 || offset + delta > 127) {
		    break;





		}
		offset += delta;
		switch (*(currentInstPtr + offset)) {
		case INST_NOP:
		    delta = InstLength(INST_NOP);
		    continue;
		case INST_JUMP1:
................................................................................
		    continue;
		case INST_JUMP4:
		    delta = TclGetInt4AtPtr(currentInstPtr + offset + 1);
		    continue;
		}
		break;
	    }

	    TclStoreInt1AtPtr(offset, currentInstPtr + 1);
	    continue;

	case INST_JUMP4:
	case INST_JUMP_TRUE4:
	case INST_JUMP_FALSE4:


	    for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {





		switch (*(currentInstPtr + offset)) {
		case INST_NOP:
		    offset += InstLength(INST_NOP);
		    continue;
		case INST_JUMP1:
		    offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
		    continue;
		case INST_JUMP4:
		    offset += TclGetInt4AtPtr(currentInstPtr + offset + 1);
		    continue;
		}
		break;
	    }

	    TclStoreInt4AtPtr(offset, currentInstPtr + 1);
	    continue;
	}
    }
}
 
/*






>




|






>



>
>
>
>
>







 







>






>
>

>
>
>
>
>













>







340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
 */

static void
AdvanceJumps(
    CompileEnv *envPtr)
{
    unsigned char *currentInstPtr;
    Tcl_HashTable jumps;

    for (currentInstPtr = envPtr->codeStart ;
	    currentInstPtr < envPtr->codeNext-1 ;
	    currentInstPtr += AddrLength(currentInstPtr)) {
	int offset, delta, isNew;

	switch (*currentInstPtr) {
	case INST_JUMP1:
	case INST_JUMP_TRUE1:
	case INST_JUMP_FALSE1:
	    offset = TclGetInt1AtPtr(currentInstPtr + 1);
	    Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
	    for (delta=0 ; offset+delta != 0 ;) {
		if (offset + delta < -128 || offset + delta > 127) {
		    break;
		}
		Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
		if (!isNew) {
		    offset = TclGetInt1AtPtr(currentInstPtr + 1);
		    break;
		}
		offset += delta;
		switch (*(currentInstPtr + offset)) {
		case INST_NOP:
		    delta = InstLength(INST_NOP);
		    continue;
		case INST_JUMP1:
................................................................................
		    continue;
		case INST_JUMP4:
		    delta = TclGetInt4AtPtr(currentInstPtr + offset + 1);
		    continue;
		}
		break;
	    }
	    Tcl_DeleteHashTable(&jumps);
	    TclStoreInt1AtPtr(offset, currentInstPtr + 1);
	    continue;

	case INST_JUMP4:
	case INST_JUMP_TRUE4:
	case INST_JUMP_FALSE4:
	    Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
	    Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew);
	    for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
		Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
		if (!isNew) {
		    offset = TclGetInt4AtPtr(currentInstPtr + 1);
		    break;
		}
		switch (*(currentInstPtr + offset)) {
		case INST_NOP:
		    offset += InstLength(INST_NOP);
		    continue;
		case INST_JUMP1:
		    offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
		    continue;
		case INST_JUMP4:
		    offset += TclGetInt4AtPtr(currentInstPtr + offset + 1);
		    continue;
		}
		break;
	    }
	    Tcl_DeleteHashTable(&jumps);
	    TclStoreInt4AtPtr(offset, currentInstPtr + 1);
	    continue;
	}
    }
}
 
/*

Changes to tests/compile.test.

708
709
710
711
712
713
714
































































715
716
717
718
719
720
721
    foo destroy
} -match glob -result *

test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
    # This will panic in a --enable-symbols=compile build, unless bug is fixed.
    apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *

































































# TODO sometime - check that bytecode from tbcload is *not* disassembled.
 
# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}






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







708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
    foo destroy
} -match glob -result *

test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
    # This will panic in a --enable-symbols=compile build, unless bug is fixed.
    apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *

test compile-20.1 {ensure there are no infinite loops in optimizing} {
    tcl::unsupported::disassemble script {
	while 1 {
	    return -code continue -level 0
	}
    }
    return
} {}
test compile-20.2 {ensure there are no infinite loops in optimizing} {
    tcl::unsupported::disassemble script {
	while 1 {
	    while 1 {
		return -code break -level 0
	    }
	}
    }
    return
} {}

test compile-21.1 {stack balance management} {
    apply {{} {
	set result {}
	while 1 {
	    lappend result a
	    lappend result [list b [break]]
	    lappend result c
	}
	return $result
    }}
} a
test compile-21.2 {stack balance management} {
    apply {{} {
	set result {}
	while {[incr i] <= 10} {
	    lappend result $i
	    lappend result [list b [continue] c]
	    lappend result c
	}
	return $result
    }}
} {1 2 3 4 5 6 7 8 9 10}
test compile-21.3 {stack balance management} {
    apply {args {
	set result {}
	while 1 {
	    lappend result a
	    lappend result [concat {*}$args [break]]
	    lappend result c
	}
	return $result
    }} P Q R S T
} a
test compile-21.4 {stack balance management} {
    apply {args {
	set result {}
	while {[incr i] <= 10} {
	    lappend result $i
	    lappend result [concat {*}$args [continue] c]
	    lappend result c
	}
	return $result
    }} P Q R S T
} {1 2 3 4 5 6 7 8 9 10}

# TODO sometime - check that bytecode from tbcload is *not* disassembled.
 
# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}

Changes to tests/for.test.

937
938
939
940
941
942
943
944







945











































































































































































































































946
947
948
949
950
951
952
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]]
	    }]
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0







 











































































































































































































































# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







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







937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
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
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]]
	    }]
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory {
    apply {{} {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {$x < 5} {incr x} {
		list a b c [apply {{} {return -code break}}] d e f
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory {
    apply {{} {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {$x < 5} {incr x} {
		list a b c [apply {{} {return -code continue}}] d e f
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory {
    apply {{} {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory {
    apply {{} {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts {*}[puts a b c {*}[apply {{} {
		    return -code continue
		}}] d e f]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory {
    apply {{} {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
		    return -code break
		}}] d e f]]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory {
    apply {{} {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
		    return -code continue
		}}] d e f]]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory {
    apply {{} {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
		    return -code break
		}}] d e f]]
	    }]
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory {
    apply {{} {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
		    return -code continue
		}}] d e f]]
	    }]
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }}
} 0
test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory {
    apply {op {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {$x < 5} {incr x} {
		list a b c [{*}$op] d e f
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code break}
} 0
test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory {
    apply {op {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {$x < 5} {incr x} {
		list a b c [{*}$op] d e f
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code continue}
} 0
test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory {
    apply {op {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts {*}[puts a b c {*}[{*}$op] d e f]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code break}
} 0
test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory {
    apply {op {
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts {*}[puts a b c {*}[{*}$op] d e f]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code continue}
} 0
test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory {
    apply {op {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code break}
} 0
test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory {
    apply {op {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
	    }
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code continue}
} 0
test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory {
    apply {op {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
	    }]
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code break}
} 0
test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory {
    apply {op {
	set l [lrepeat 50 p q r]
	# Can't use [memtest]; must be careful when we change stack frames
	set end [meminfo]
	for {set i 0} {$i < 5} {incr i} {
	    unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
		puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
	    }]
	    set tmp $end
	    set end [meminfo]
	}
	expr {$end - $tmp}
    }} {return -level 0 -code continue}
} 0
 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: