diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 309 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 |
3 files changed, 211 insertions, 105 deletions
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; |