diff options
| -rw-r--r-- | ChangeLog | 85 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 309 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 |
4 files changed, 257 insertions, 144 deletions
@@ -1,3 +1,10 @@ +2008-08-24 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCmdAH.c (TclNRForeachCmd): Converted the [foreach] + command to have an NRE-aware non-compiled implementation. Part of the + [Bug 2017632] project. Also restructured the code so as to manage its + temporary memory more efficiently. + 2008-08-23 Miguel Sofer <msofer@users.sf.net> * generic/tclBasic.c: Removed unused var; fixed function @@ -27,19 +34,19 @@ * changes: Updates for 8.6a2 release. - * generic/tcl.h: Drop use of USE_COMPAT85_CONST. That added - indirection without value. Use -DCONST86="" to engage source compat + * generic/tcl.h: Drop use of USE_COMPAT85_CONST. That added + indirection without value. Use -DCONST86="" to engage source compat support for code written for 8.5 headers. * generic/tclUtil.c (TclReToGlob): Added missing set of the - *exactPtr value to really fix [Bug 2065115]. Also avoid possible + *exactPtr value to really fix [Bug 2065115]. Also avoid possible DString overflow. * tests/regexpComp.test: Correct duplicate test names. 2008-08-21 Miguel Sofer <msofer@users.sf.net> * generic/tclBasic.c: Previous fix, now done right. - * generic/tclCmdIL.c: + * generic/tclCmdIL.c: * generic/tclInt.h: * tests/unsupported.test: @@ -55,7 +62,7 @@ * generic/tcl.decls: the use of CONST86_RETURN to support source code compatibility with Tcl 8.5 on those public routines passing (Tcl_Filesystem *), (Tcl_Timer *), and (Tcl_Objtype *) values which - have been const-ified. What remains is the minimum configurability + have been const-ified. What remains is the minimum configurability needed to support code written for pre-8.6 headers via the new -DUSE_COMPAT85_CONST compiler directive. *** POTENTIAL INCOMPATIBILITY *** @@ -178,7 +185,7 @@ 2008-08-08 Don Porter <dgp@users.sourceforge.net>S * generic/tclOOMethod.c (PushMethodCallFrame): Added missing check - for bytecode validity. [Bug 2037727] + for bytecode validity. [Bug 2037727] * generic/tclProc.c (TclProcCompileProc): On recompile of a proc, clear away any entries on the CompiledLocal list from the @@ -365,9 +372,9 @@ * generic/tclBasic.c: Revised timing of the CmdFrame stack management * tests/info.test: in TclEvalEx so that the CmdFrame will still be on the stack at the time Tcl_LogCommandInfo is called to append - another level of -errorinfo information. Sets the stage to add - file and line data to the stack trace. Added test to check that - [info frame] functioning remains unchanged by the revision. + another level of -errorinfo information. Sets the stage to add file + and line data to the stack trace. Added test to check that [info + frame] functioning remains unchanged by the revision. 2008-07-31 Miguel Sofer <msofer@users.sf.net> @@ -961,7 +968,7 @@ * generic/tclPathObj.c: Fixed some internals management in the "path" Tcl_ObjType for the empty string value. Problem led to a crash in the - command [glob -dir {} a]. [Bug 1999176]. + command [glob -dir {} a]. [Bug 1999176] 2008-06-24 Pat Thoyts <patthoyts@users.sourceforge.net> @@ -1475,7 +1482,7 @@ 2008-04-14 Kevin B. Kenny <kennykb@acm.org> * unix/tclUnixTime.c (NativeGetTime): Removed obsolete use of - 'struct timezone' in the call to 'gettimeofday'. [Bug 1942197]. + 'struct timezone' in the call to 'gettimeofday'. [Bug 1942197] * tests/clock.test (clock-33.5, clock-33.5a, clock-33.8, clock-33.8a): Added comments to the test that it can fail on a heavily loaded @@ -1512,10 +1519,10 @@ * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Added checking of -size value * tests/ioCmd.test (iocmd-15.{13,14}): to reject negative values, and - values overflowing 32-bit signed. [Bug 1557855]. Basic patch by - Alexandre Ferrieux <ferrieux@users.sourceforge.net>, with - modifications from me to separate overflow from true negative value. - Extended testsuite. + values overflowing 32-bit signed. Basic patch by Alexandre Ferrieux + <ferrieux@users.sourceforge.net>, with modifications from me to + separate overflow from true negative value. Extended testsuite. [Bug + 1557855] 2008-04-09 Daniel Steffen <das@users.sourceforge.net> @@ -1549,8 +1556,8 @@ * generic/tclIO.c (BUSY_STATE, CheckChannelErrors, TclCopyChannel): New macro, and the places using it. This change allows for - bi-directional fcopy on channels. [Bug 1350564]. Thanks to Alexandre - Ferrieux <ferrieux@users.sourceforge.net> for the patch. + bi-directional fcopy on channels. Thanks to Alexandre Ferrieux + <ferrieux@users.sourceforge.net> for the patch. [Bug 1350564] 2008-04-07 Reinhard Max <max@suse.de> @@ -1664,7 +1671,7 @@ * generic/tclBasic.c: Revised stubs-generation tool and interp * tools/genStubs.tcl: creation so that "tclStubsPtr" is not present * unix/Makefile.in: in libtcl.so, but is present only in - * win/Makefile.in: libtclstub.a. This tightens up the rules for + * win/Makefile.in: libtclstub.a. This tightens up the rules for * win/makefile.bc: users of the stubs interfaces. [Bug 1819422] * win/makefile.vc: @@ -1802,10 +1809,10 @@ 2008-03-18 Andreas Kupries <andreask@activestate.com> * library/tm.tcl (::tcl::tm::Defaults): Modified handling of - environment variables. See [Bug 1914604]. Solution slightly different - than proposed in the report. Using the underscored form TCLX_y_TM_PATH - even if TCLX.y_TM_PATH exists. Also using a loop to cut prevent code - replication. + environment variables. Solution slightly different than proposed in + the report. Using the underscored form TCLX_y_TM_PATH even if + TCLX.y_TM_PATH exists. Also using a loop to cut prevent code + replication. [Bug 1914604] 2008-03-16 Donal K. Fellows <dkf@users.sf.net> @@ -1992,7 +1999,7 @@ * generic/tclResult.c (Tcl_SetReturnOptions): Revised the refcount management of Tcl_SetReturnOptions to become that of a conventional - Consumer routine. Thanks to Peter Spjuth for pointing out the + Consumer routine. Thanks to Peter Spjuth for pointing out the difficulties calling Tcl_SetReturnOptions with non-0-count value for options. * generic/tclExecute.c (INST_RETURN_STK): Revised the one caller @@ -2018,7 +2025,7 @@ * unix/tclUnixChan.c, unix/tclUnixNotfy.c, unix/tclUnixPipe.c: Consolidate all code conditionalized on -DUSE_FIONBIO into one place. * unix/tclUnixPort.h, unix/tclUnixCompat.c: New routine - TclUnixSetBlockingMode() [Patch 1903339]. + TclUnixSetBlockingMode(). [Patch 1903339] 2008-02-28 Don Porter <dgp@users.sourceforge.net> @@ -2059,7 +2066,7 @@ * generic/tclIOUtil.c, unix/tclUnixPort.h, unix/tclUnixChan.c: Remove dead/unused portability-related #defines and unused conditional - code. See [Patch 1901828] for discussion. + code. See [Patch 1901828] for discussion. 2008-02-26 Joe English <jenglish@users.sourceforge.net> @@ -2319,7 +2326,7 @@ 2007-12-21 Miguel Sofer <msofer@users.sf.net> - * generic/tclCmdIL.c: Speed patch for lsort [Patch 1856994]. + * generic/tclCmdIL.c: Speed patch for lsort. [Patch 1856994] 2007-12-21 Miguel Sofer <msofer@users.sf.net> @@ -2343,8 +2350,8 @@ * generic/tclCompCmds.c (TclCompileSwitchCmd): update switch -regexp * tests/switch.test-14.*: compilation to pass - the cflags to INST_REGEXP (changed on 12-07). Added tests for - switch -regexp compilation (need more). [Bug 1854399] + the cflags to INST_REGEXP (changed on 12-07). Added tests for switch + -regexp compilation (need more). [Bug 1854399] 2007-12-18 Don Porter <dgp@users.sourceforge.net> @@ -2396,8 +2403,8 @@ 2007-12-12 Don Porter <dgp@users.sourceforge.net> * doc/IntObj.3: Update docs for the Tcl_GetBignumAndClearObj() -> - Tcl_TakeBignumFromObj() revision [TIP 298]. Added docs for the - Tcl_InitBignumFromDouble() routine. [Bug 1446971]. + Tcl_TakeBignumFromObj() revision [TIP 298]. Added docs for the + Tcl_InitBignumFromDouble() routine. [Bug 1446971] * changes: Updated for 8.5.0 release. @@ -2472,11 +2479,11 @@ 2007-12-06 Don Porter <dgp@users.sourceforge.net> * README: Remove mention of dead comp.lang.tcl.announce - newsgroup. [Bug 1846433]. + newsgroup. [Bug 1846433] * unix/README: Mention the stub library created by `make` and warn about the effect of embedded paths in the installed binaries. - Thanks to Larry Virden. [Bug 1794084] + Thanks to Larry Virden. [Bug 1794084] * doc/AddErrInfo.3: Documentation for the new routines in TIP 270. * doc/Interp.3: @@ -2509,7 +2516,7 @@ 2007-12-05 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclIO.h: Create Tcl_Obj for Tcl channels to reduce - * generic/tclIO.c: overhead in lookup by Tcl_GetChannel. New + * generic/tclIO.c: overhead in lookup by Tcl_GetChannel. New * generic/tclIOCmd.c: TclGetChannelFromObj for internal use. * generic/tclIO.c (WriteBytes, WriteChars): add opt check to avoid EOL translation when not linebuffered or using lf. [Bug 1845092] @@ -4910,8 +4917,8 @@ * library/msgs/ja.msg: * tools/loadICU.tcl: Corrected several localisation faults in the Japanese locale (most notably, incorrect dates for the Emperors' - eras). [Bug 1637471]. Many thanks to SourceForge user 'nyademo' for - pointing this out and developing a fix. + eras). Many thanks to SourceForge user 'nyademo' for pointing this out + and developing a fix. [Bug 1637471] * generic/tclPathObj.c: Corrected a 'const'ness fault that caused bitter complaints from MSVC. * tests/clock.test (clock-40.1, clock-58.1, clock-59.1): Corrected a @@ -5987,7 +5994,7 @@ * tests/event.test (event-14.*): Corrected a bug where TclUnixWaitForFile would present select() with the wrong mask on an LP64 machine if a fd number exceeds 32. Thanks to Jean-Luc Fontaine - for reporting and diagnosing [Bug 1602208]. + for reporting and diagnosing. [Bug 1602208] 2006-11-27 Don Porter <dgp@users.sourceforge.net> @@ -7496,9 +7503,9 @@ * generic/tclProc.c (ProcCompileProc): When a bump of the compile epoch forces the re-compile of a proc body, take care not to overwrite - any Proc struct that may be referred to on the active call stack. This - fixes [Bug 1482718]. Note that the fix will not be effective for code - that calls the private routine TclProcCompileProc() directly. + any Proc struct that may be referred to on the active call stack. Note + that the fix will not be effective for code that calls the private + routine TclProcCompileProc() directly. [Bug 1482718] 2006-05-13 Daniel Steffen <das@users.sourceforge.net> diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3eb9908..68b32bb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.362 2008/08/23 18:53:09 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.363 2008/08/24 14:38:08 dkf Exp $ */ #include "tclInt.h" @@ -177,7 +177,7 @@ static const CmdInfo builtInCmds[] = { {"eval", Tcl_EvalObjCmd, NULL, NULL, 1}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, NULL, 1}, {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, NULL, 1}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 8e26dcf..272cb20 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,13 +10,33 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.102 2008/08/17 19:37:11 msofer Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.103 2008/08/24 14:38:11 dkf Exp $ */ #include "tclInt.h" #include <locale.h> /* + * The state structure used by [foreach]. Note that the actual structure has + * all its working arrays appended afterwards so they can be allocated and + * freed in a single step. + */ + +struct ForeachState { + Tcl_Obj *bodyPtr; /* The script body of the command. */ + int bodyIdx; /* The argument index of the body. */ + int j, maxj; /* Number of loop iterations. */ + int numLists; /* Count of value lists. */ + int *index; /* Array of value list indices. */ + int *varcList; /* # loop variables per list. */ + Tcl_Obj ***varvList; /* Array of var name lists. */ + Tcl_Obj **vCopyList; /* Copies of var name list arguments. */ + int *argcList; /* Array of value list sizes. */ + Tcl_Obj ***argvList; /* Array of value lists. */ + Tcl_Obj **aCopyList; /* Copies of value list arguments. */ +}; + +/* * Prototypes for local procedures defined in this file: */ @@ -25,6 +45,10 @@ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static inline int ForeachAssignments(Tcl_Interp *interp, + struct ForeachState *statePtr); +static inline void ForeachCleanup(Tcl_Interp *interp, + struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); static char * GetTypeFromMode(int mode); @@ -32,8 +56,7 @@ static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ForNextCallback; - - +static Tcl_NRPostProc ForeachLoopStep; /* *---------------------------------------------------------------------- @@ -1639,7 +1662,6 @@ Tcl_ForObjCmd( return Tcl_NRCallObjProc(interp, TclNRForObjCmd, dummy, objc, objv); } - int TclNRForObjCmd( ClientData dummy, /* Not used. */ @@ -1760,7 +1782,7 @@ ForNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd -- + * Tcl_ForeachObjCmd, TclNRForeachCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -1782,21 +1804,19 @@ Tcl_ForeachObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int result = TCL_OK; - int i; /* i selects a value list */ - int j, maxj; /* Number of loop iterations */ - int v; /* v selects a loop variable */ - int numLists = (objc-2)/2; /* Count of value lists */ - Tcl_Obj *bodyPtr; - Interp *iPtr = (Interp *) interp; + return Tcl_NRCallObjProc(interp, TclNRForeachCmd, dummy, objc, objv); +} - int *index; /* Array of value list indices */ - int *varcList; /* # loop variables per list */ - Tcl_Obj ***varvList; /* Array of var name lists */ - Tcl_Obj **vCopyList; /* Copies of var name list arguments */ - int *argcList; /* Array of value list sizes */ - Tcl_Obj ***argvList; /* Array of value lists */ - Tcl_Obj **aCopyList; /* Copies of value list arguments */ +int +TclNRForeachCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int numLists = (objc-2) / 2; + register struct ForeachState *statePtr; + int i, j, result; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1806,129 +1826,214 @@ Tcl_ForeachObjCmd( /* * Manage numList parallel value lists. - * argvList[i] is a value list counted by argcList[i]l; - * varvList[i] is the list of variables associated with the value list; - * varcList[i] is the number of variables associated with the value list; - * index[i] is the current pointer into the value list argvList[i]. + * statePtr->argvList[i] is a value list counted by statePtr->argcList[i]; + * statePtr->varvList[i] is the list of variables associated with the + * value list; + * statePtr->varcList[i] is the number of variables associated with the + * value list; + * statePtr->index[i] is the current pointer into the value list + * statePtr->argvList[i]. + * + * The setting up of all of these pointers is moderately messy, but allows + * the rest of this code to be simple and for us to use a single memory + * allocation for better performance. */ - index = (int *) TclStackAlloc(interp, 3 * numLists * sizeof(int)); - varcList = index + numLists; - argcList = varcList + numLists; - memset(index, 0, 3 * numLists * sizeof(int)); - - varvList = (Tcl_Obj ***) - TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj **)); - argvList = varvList + numLists; - memset(varvList, 0, 2 * numLists * sizeof(Tcl_Obj **)); - - vCopyList = (Tcl_Obj **) - TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj *)); - aCopyList = vCopyList + numLists; - memset(vCopyList, 0, 2 * numLists * sizeof(Tcl_Obj *)); + statePtr = TclStackAlloc(interp, + sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); + memset(statePtr, 0, + sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); + statePtr->varvList = (Tcl_Obj ***) (statePtr + 1); + statePtr->argvList = statePtr->varvList + numLists; + statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists); + statePtr->aCopyList = statePtr->vCopyList + numLists; + statePtr->index = (int *) (statePtr->aCopyList + numLists); + statePtr->varcList = statePtr->index + numLists; + statePtr->argcList = statePtr->varcList + numLists; + + statePtr->numLists = numLists; + statePtr->bodyPtr = objv[objc - 1]; + statePtr->bodyIdx = objc - 1; /* * Break up the value lists and variable lists into elements. */ - maxj = 0; for (i=0 ; i<numLists ; i++) { - - vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); - if (vCopyList[i] == NULL) { + statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); + if (statePtr->vCopyList[i] == NULL) { result = TCL_ERROR; goto done; } - TclListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]); - if (varcList[i] < 1) { + TclListObjGetElements(NULL, statePtr->vCopyList[i], + &statePtr->varcList[i], &statePtr->varvList[i]); + if (statePtr->varcList[i] < 1) { Tcl_AppendResult(interp, "foreach varlist is empty", NULL); result = TCL_ERROR; goto done; } - aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); - if (aCopyList[i] == NULL) { + statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); + if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } - TclListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]); + TclListObjGetElements(NULL, statePtr->aCopyList[i], + &statePtr->argcList[i], &statePtr->argvList[i]); - j = argcList[i] / varcList[i]; - if ((argcList[i] % varcList[i]) != 0) { + j = statePtr->argcList[i] / statePtr->varcList[i]; + if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { j++; } - if (j > maxj) { - maxj = j; + if (j > statePtr->maxj) { + statePtr->maxj = j; } } /* - * Iterate maxj times through the lists in parallel. If some value lists - * run out of values, set loop vars to "" + * If there is any work to do, assign the variables and set things going + * non-recursively. */ - bodyPtr = objv[objc-1]; - for (j=0 ; j<maxj ; j++) { - for (i=0 ; i<numLists ; i++) { - for (v=0 ; v<varcList[i] ; v++) { - int k = index[i]++; - Tcl_Obj *valuePtr, *varValuePtr; + if (statePtr->maxj > 0) { + result = ForeachAssignments(interp, statePtr); + if (result == TCL_ERROR) { + goto done; + } - if (k < argcList[i]) { - valuePtr = argvList[i][k]; - } else { - valuePtr = Tcl_NewObj(); /* Empty string */ - } - varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, - valuePtr, TCL_LEAVE_ERR_MSG); - if (varValuePtr == NULL) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting foreach loop variable \"%s\")", - TclGetString(varvList[i][v]))); - result = TCL_ERROR; - goto done; - } - } + TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); + return TclNREvalObjEx(interp, objv[objc-1], 0, + ((Interp *) interp)->cmdFramePtr, objc-1); + } + + /* + * This cleanup stage is only used when an error occurs during setup or if + * there is no work to do. + */ + + result = TCL_OK; + done: + ForeachCleanup(interp, statePtr); + return result; +} + +/* + * Post-body processing handler. + */ + +static int +ForeachLoopStep( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + register struct ForeachState *statePtr = data[0]; + + /* + * Process the result code from this run of the [foreach] body. Note that + * this switch uses fallthroughs in several places. Maintainer aware! + */ + + switch (result) { + case TCL_CONTINUE: + result = TCL_OK; + case TCL_OK: + break; + case TCL_BREAK: + result = TCL_OK; + goto done; + case TCL_ERROR: + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"foreach\" body line %d)", interp->errorLine)); + default: + goto done; + } + + /* + * Test if there is work still to be done. If so, do the next round of + * variable assignments, reschedule ourselves and run the body again. + */ + + if (statePtr->maxj > ++statePtr->j) { + result = ForeachAssignments(interp, statePtr); + if (result == TCL_ERROR) { + goto done; } - /* - * TIP #280. Make invoking context available to loop body. - */ + TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); + return TclNREvalObjEx(interp, statePtr->bodyPtr, 0, + ((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx); + } - result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr, objc-1); - if (result != TCL_OK) { - if (result == TCL_CONTINUE) { - result = TCL_OK; - } else if (result == TCL_BREAK) { - result = TCL_OK; - break; - } else if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"foreach\" body line %d)", - interp->errorLine)); - break; + /* + * We're done. Tidy up our work space and finish off. + */ + + Tcl_ResetResult(interp); + done: + ForeachCleanup(interp, statePtr); + return result; +} + +/* + * Factored out code to do the assignments in [foreach]. + */ + +static inline int +ForeachAssignments( + Tcl_Interp *interp, + struct ForeachState *statePtr) +{ + int i, v, k; + Tcl_Obj *valuePtr, *varValuePtr; + + for (i=0 ; i<statePtr->numLists ; i++) { + for (v=0 ; v<statePtr->varcList[i] ; v++) { + k = statePtr->index[i]++; + + if (k < statePtr->argcList[i]) { + valuePtr = statePtr->argvList[i][k]; } else { - break; + TclNewObj(valuePtr); /* Empty string */ + } + + varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + + if (varValuePtr == NULL) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (setting foreach loop variable \"%s\")", + TclGetString(statePtr->varvList[i][v]))); + return TCL_ERROR; } } } - if (result == TCL_OK) { - Tcl_ResetResult(interp); - } - done: - for (i=0 ; i<numLists ; i++) { - if (vCopyList[i]) { - Tcl_DecrRefCount(vCopyList[i]); + return TCL_OK; +} + +/* + * Factored out code for cleaning up the state of the foreach. + */ + +static inline void +ForeachCleanup( + Tcl_Interp *interp, + struct ForeachState *statePtr) +{ + int i; + + for (i=0 ; i<statePtr->numLists ; i++) { + if (statePtr->vCopyList[i]) { + TclDecrRefCount(statePtr->vCopyList[i]); } - if (aCopyList[i]) { - Tcl_DecrRefCount(aCopyList[i]); + if (statePtr->aCopyList[i]) { + TclDecrRefCount(statePtr->aCopyList[i]); } } - TclStackFree(interp, vCopyList); /* Tcl_Obj * arrays */ - TclStackFree(interp, varvList); /* Tcl_Obj ** arrays */ - TclStackFree(interp, index); /* int arrays */ - return result; + TclStackFree(interp, statePtr); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index f5b7ba5..f9a53a9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.395 2008/08/23 11:35:52 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.396 2008/08/24 14:38:11 dkf Exp $ */ #ifndef _TCLINT @@ -2557,6 +2557,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; |