Index: doc/array.n ================================================================== --- doc/array.n +++ doc/array.n @@ -44,10 +44,17 @@ \fBarray startsearch\fR. Returns an empty string. .TP \fBarray exists \fIarrayName\fR Returns 1 if \fIarrayName\fR is an array variable, 0 if there is no variable by that name or if it is a scalar variable. +.TP +\fBarray for {\fIkeyVariable ?valueVariable?\fB} \fIarrayName body\fR +The first argument is a one or two element list of variable names for the +key and value of each entry in the array. The second argument is the +array name to iterate over. The third argument is the body to execute +for each key and value returned. +The ordering of the returned keys is undefined. .TP \fBarray get \fIarrayName\fR ?\fIpattern\fR? Returns a list containing pairs of elements. The first element in each pair is the name of an element in \fIarrayName\fR and the second element of each pair is the value of the Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -2321,10 +2321,23 @@ # TIP #400 declare 630 { void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj) } + +# TIP #421 +declare 632 { + void Tcl_ArrayObjFirst(Tcl_Interp *interp, + Tcl_Obj *arrayObj, + Tcl_ArraySearch *searchPtr) +} +declare 633 { + int Tcl_ArrayObjNext(Tcl_Interp *interp, + Tcl_ArraySearch *searchPtr, + Tcl_Obj **keyPtrPtr, + Tcl_Obj **valuePtrPtr) +} # ----- BASELINE -- FOR -- 8.6.0 ----- # ############################################################################## Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -1332,10 +1332,41 @@ #define TCL_STRING_KEYS (0) #define TCL_ONE_WORD_KEYS (1) #define TCL_CUSTOM_TYPE_KEYS (-2) #define TCL_CUSTOM_PTR_KEYS (-1) +/* + * The following structure describes an enumerative search in progress on an + * array variable; this are invoked with options to the "array" command. + */ + +# define TCL_ARRAYSEARCH_FOR_VALUE 0x0001 +typedef struct ArraySearch { + Tcl_Obj *name; /* Name of this search */ + int id; /* Integer id used to distinguish among + * multiple concurrent searches for the same + * array. */ + struct Var *varPtr; /* Pointer to array variable that's being + * searched. */ + Tcl_Obj *arrayNameObj; /* Name of the array variable in the current + * resolution context. Usually NULL except for + * in "array for". */ + int flags; /* Used by 'array for' to check if the + * value is wanted. */ + Tcl_HashSearch search; /* Info kept by the hash module about progress + * through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to + * be enumerated (it's leftover from the + * Tcl_FirstHashEntry call or from an "array + * anymore" command). NULL means must call + * Tcl_NextHashEntry to get value to + * return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches for + * this variable, or NULL if this is the last + * one. */ +} Tcl_ArraySearch; + /* * Structure definition for information used to keep track of searches through * dictionaries. These fields should not be accessed by code outside * tclDictObj.c */ Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -47,10 +47,13 @@ Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); static int CompileDictEachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr, int collect); +static int CompileArrayEachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); /* * The structures below define the AuxData types defined in this file. */ @@ -284,10 +287,225 @@ } else { TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); } return TCL_OK; } + +int +TclCompileArrayForCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return CompileArrayEachCmd(interp, parsePtr, cmdPtr, envPtr); +} + +int +CompileArrayEachCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr /* Holds resulting instructions. */ + ) +{ + DefineLineInformation; + Tcl_Token *varsTokenPtr, *arrayTokenPtr, *bodyTokenPtr; + int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; + int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; + int numVars, endTargetOffset; + const char **argv; + Tcl_DString buffer; + + /* + * There must be three arguments after the command. + */ + + if (parsePtr->numWords != 4) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + varsTokenPtr = TokenAfter(parsePtr->tokenPtr); + arrayTokenPtr = TokenAfter(varsTokenPtr); + bodyTokenPtr = TokenAfter(arrayTokenPtr); + if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || + arrayTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || + bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + /* + * Check we've got one or two variables and that they are local variables. + * Then extract their indices in the LVT. + */ + + Tcl_DStringInit(&buffer); + TclDStringAppendToken(&buffer, &varsTokenPtr[1]); + if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars, + &argv) != TCL_OK) { + Tcl_DStringFree(&buffer); + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + Tcl_DStringFree(&buffer); + /* + * both + * array for {k} a {} + * array for {k v} a {} + * are supported. + */ + if (numVars != 1 && numVars != 2) { + ckfree(argv); + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + nameChars = strlen(argv[0]); + keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); + valueVarIndex = -1; + if (numVars == 2) { + nameChars = strlen(argv[1]); + valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); + } + ckfree(argv); + + if ((keyVarIndex < 0) || (numVars == 2 && valueVarIndex < 0)) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + /* + * Allocate a temporary variable to store the iterator reference. The + * variable will contain a Tcl_ArraySearch reference which will be + * allocated by INST_ARRAY_FIRST and disposed when the variable is unset + * (at which point it should also have been finished with). + */ + + infoIndex = AnonymousLocal(envPtr); + if (infoIndex < 0) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + /* + * Preparation complete; issue instructions. Note that this code issues + * fixed-sized jumps. That simplifies things a lot! + */ + + /* + * Get the array and start the iteration. No catching of errors at + * this point. + */ + + CompileWord(envPtr, arrayTokenPtr, interp, 2); + + /* + * Now we catch errors from here on + */ + + TclEmitInstInt4( INST_ARRAY_FIRST, infoIndex, envPtr); + + catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + ExceptionRangeStarts(envPtr, catchRange); + + /* + * Set up the loop exception targets. + */ + + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, loopRange); + + /* + * Inside the iteration, fetch and write the loop variables. + */ + + bodyTargetOffset = CurrentOffset(envPtr); + + TclEmitInstInt4( INST_ARRAY_NEXT, infoIndex, envPtr); + emptyTargetOffset = CurrentOffset(envPtr); + + Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + if (valueVarIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + + /* + * Compile the loop body itself. It should be stack-neutral. + */ + + BODY(bodyTokenPtr, 3); + TclEmitOpcode( INST_POP, envPtr); + + /* + * Both exception target ranges (error and loop) end here. + */ + + ExceptionRangeEnds(envPtr, loopRange); + ExceptionRangeEnds(envPtr, catchRange); + + /* + * Continue (or just normally process) by getting the next pair of items + * from the dictionary and jumping back to the code to write them into + * variables if there is another pair. + */ + + TclAdjustStackDepth(-1, envPtr); + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + TclEmitInstInt4( INST_ARRAY_NEXT, infoIndex, envPtr); + jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); + /* + * checks the 'done' boolean on the stack and if false, + * goes back to the top of the loop + */ + TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + endTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP1, 0, envPtr); + + /* + * Error handler "finally" clause, which force-terminates the iteration + * and rethrows the error. + */ + + ExceptionRangeTarget(envPtr, catchRange, catchOffset); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); + + /* + * Otherwise we're done and we + * need to pop the bogus key/value pair (pushed to keep stack calculations + * easy!) Note that we skip the END_CATCH. [Bug 1382528] + */ + + jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; + TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, + envPtr->codeStart + emptyTargetOffset); + jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; + TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, + envPtr->codeStart + endTargetOffset); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, loopRange); + TclEmitOpcode( INST_END_CATCH, envPtr); + + /* + * Final stage of the command (normal case) is that we push an empty + * object (or push the accumulator as the result object). This is done + * last to promote peephole optimization when it's dropped immediately. + */ + + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + int TclCompileArraySetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -520,11 +520,10 @@ * array. * Stack: ... varName => ... */ {"arrayMakeImm", 5, 0, 1, {OPERAND_LVT4}}, /* Forces the variable indexed by opnd to be an array. Does not touch * the stack. */ - {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, /* Invoke command named objv[0], replacing the first two words with * the word at the top of the stack; * = */ @@ -651,11 +650,15 @@ /* Lappend list to array element. * Stack: ... arrayName elem list => ... listVarContents */ {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ - + {"arrayFirst", 5, 0, 1, {OPERAND_LVT4}}, + /* Set up iteration over the array + * no stack effect */ + {"arrayNext", 5, +3, 1, {OPERAND_LVT4}}, + /* Stack: key value done */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* * Prototypes for procedures defined later in this file: Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -819,12 +819,15 @@ #define INST_LAPPEND_LIST 185 #define INST_LAPPEND_LIST_ARRAY 186 #define INST_LAPPEND_LIST_ARRAY_STK 187 #define INST_LAPPEND_LIST_STK 188 +#define INST_ARRAY_FIRST 189 +#define INST_ARRAY_NEXT 190 + /* The last opcode */ -#define LAST_INST_OPCODE 188 +#define LAST_INST_OPCODE 190 /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed @@ -1239,11 +1242,11 @@ #define TclCheckStackDepth(depth, envPtr) \ do { \ int dd = (depth); \ if (dd != (envPtr)->currStackDepth) { \ Tcl_Panic("bad stack depth computations: is %i, should be %i", \ - (envPtr)->currStackDepth, dd); \ + (envPtr)->currStackDepth, dd); \ } \ } while (0) /* * Macro used to update the stack requirements. It is called by the macros Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -1814,10 +1814,19 @@ Tcl_LoadHandle handlePtr); /* 630 */ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); +/* Slot 631 is reserved */ +/* 632 */ +EXTERN void Tcl_ArrayObjFirst(Tcl_Interp *interp, + Tcl_Obj *arrayObj, + Tcl_ArraySearch *searchPtr); +/* 633 */ +EXTERN int Tcl_ArrayObjNext(Tcl_Interp *interp, + Tcl_ArraySearch *searchPtr, + Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -2480,10 +2489,13 @@ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ + void (*reserved631)(void); + void (*tcl_ArrayObjFirst) (Tcl_Interp *interp, Tcl_Obj *arrayObj, Tcl_ArraySearch *searchPtr); /* 632 */ + int (*tcl_ArrayObjNext) (Tcl_Interp *interp, Tcl_ArraySearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr); /* 633 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -3772,10 +3784,15 @@ (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +/* Slot 631 is reserved */ +#define Tcl_ArrayObjFirst \ + (tclStubsPtr->tcl_ArrayObjFirst) /* 632 */ +#define Tcl_ArrayObjNext \ + (tclStubsPtr->tcl_ArrayObjNext) /* 633 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -764,10 +764,11 @@ static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); +static void ReleaseArrayIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; @@ -795,10 +796,15 @@ static const Tcl_ObjType dictIteratorType = { "dictIterator", ReleaseDictIterator, NULL, NULL, NULL +}; +static const Tcl_ObjType arrayIteratorType = { + "arrayIterator", + ReleaseArrayIterator, + NULL, NULL, NULL }; /* *---------------------------------------------------------------------- * @@ -833,10 +839,49 @@ ckfree(searchPtr); dictPtr = objPtr->internalRep.twoPtrValue.ptr2; TclDecrRefCount(dictPtr); + objPtr->typePtr = NULL; +} + + +/* + *---------------------------------------------------------------------- + * + * ReleaseArrayIterator -- + * + * This takes apart an array iterator that is stored in the given Tcl + * object. + * + * Results: + * None. + * + * Side effects: + * Deallocates memory, marks the object as being untyped. + * + *---------------------------------------------------------------------- + */ + +static void +ReleaseArrayIterator( + Tcl_Obj *objPtr) +{ + Tcl_ArraySearch *searchPtr; + Tcl_Obj *arrayPtr; + + /* + * First kill the search, and then release the reference to the dictionary + * that we were holding. + */ + + searchPtr = objPtr->internalRep.twoPtrValue.ptr1; + ckfree(searchPtr); + + arrayPtr = objPtr->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(arrayPtr); + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- @@ -4177,10 +4222,64 @@ } else { objResultPtr = TCONST(0); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); + + { + int done; + Tcl_Obj *arrayObj, *statePtr, *keyPtr, *valuePtr; + Tcl_Obj *emptyPtr; + Tcl_ArraySearch *searchPtr; + + case INST_ARRAY_FIRST: + pcAdjustment = 1; + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + arrayObj = POP_OBJECT(); + searchPtr = ckalloc(sizeof(Tcl_ArraySearch)); + Tcl_ArrayObjFirst(interp, arrayObj, searchPtr); + TclNewObj(statePtr); + statePtr->typePtr = &arrayIteratorType; + statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; + statePtr->internalRep.twoPtrValue.ptr2 = arrayObj; + varPtr = LOCAL(opnd); + if (varPtr->value.objPtr) { + if (varPtr->value.objPtr->typePtr == &arrayIteratorType) { + Tcl_Panic("mis-issued arrayFirst!"); + } + TclDecrRefCount(varPtr->value.objPtr); + } + varPtr->value.objPtr = statePtr; + Tcl_IncrRefCount(statePtr); + NEXT_INST_F(1, 0, 0); /*### ??? */ + + case INST_ARRAY_NEXT: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + statePtr = (*LOCAL(opnd)).value.objPtr; + if (statePtr == NULL || statePtr->typePtr != &arrayIteratorType) { + Tcl_Panic("mis-issued dictNext!"); + } + searchPtr = statePtr->internalRep.twoPtrValue.ptr1; + done = Tcl_ArrayObjNext(interp, searchPtr, &keyPtr, &valuePtr); + if (done) { + TclNewObj(emptyPtr); + PUSH_OBJECT(emptyPtr); + PUSH_OBJECT(emptyPtr); + } else { + if (valuePtr != NULL) { + PUSH_OBJECT(valuePtr); + } else { + PUSH_OBJECT(emptyPtr); + } + PUSH_OBJECT(keyPtr); + } + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); + JUMP_PEEPHOLE_F(done, 5, 0); /* ### ??? */ + } case INST_ARRAY_MAKE_IMM: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; cleanup = 0; Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -3496,10 +3496,13 @@ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileArrayForCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -1414,8 +1414,11 @@ Tcl_NRSubstObj, /* 626 */ Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + 0, /* 631 */ + Tcl_ArrayObjFirst, /* 632 */ + Tcl_ArrayObjNext, /* 633 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -141,41 +141,17 @@ * true if we are inside a procedure body. */ #define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC) -/* - * The following structure describes an enumerative search in progress on an - * array variable; this are invoked with options to the "array" command. - */ - -typedef struct ArraySearch { - Tcl_Obj *name; /* Name of this search */ - int id; /* Integer id used to distinguish among - * multiple concurrent searches for the same - * array. */ - struct Var *varPtr; /* Pointer to array variable that's being - * searched. */ - Tcl_HashSearch search; /* Info kept by the hash module about progress - * through the array. */ - Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to - * be enumerated (it's leftover from the - * Tcl_FirstHashEntry call or from an "array - * anymore" command). NULL means must call - * Tcl_NextHashEntry to get value to - * return. */ - struct ArraySearch *nextPtr;/* Next in list of all active searches for - * this variable, or NULL if this is the last - * one. */ -} ArraySearch; - /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks); +static Tcl_NRPostProc ArrayForLoopCallback; static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, @@ -182,11 +158,11 @@ int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, const char *otherP2, const int otherFlags, Tcl_Obj *myNamePtr, int myFlags, int index); -static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, +static Tcl_ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); static Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj); @@ -2829,10 +2805,319 @@ } /* *---------------------------------------------------------------------- * + * ArrayForNRCmd -- + * ArrayForLoopCallback + * + * These functions implement the "array for" Tcl command. + * array for {k} a {} + * array for {k v} a {} + * The array for command iterates over the array, setting the + * the specified loop variables, and executing the body each iteration. + * + * ArrayForNRCmd() sets up the Tcl_ArraySearch structure, sets arrayNamePtr + * inside the structure and calls VarHashFirstEntry to start the hash + * iteration. + * + * ArrayForNRCmd() does not execute the body or set the loop variables, + * it only initializes the iterator. + * + * ArrayForLoopCallback() iterates over the entire array, executing + * the body each time. + * + *---------------------------------------------------------------------- + */ + +static int +ArrayForNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; + Tcl_Obj **varv; + Tcl_Obj *arrayNameObj; + Tcl_ArraySearch *searchPtr = NULL; + Var *varPtr; + Var *arrayPtr; + int varc; + + /* + * array for {k} a body + * array for {k v} a body + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "{keyVarName ?valueVarName?} array script"); + return TCL_ERROR; + } + + /* + * Parse arguments. + */ + + if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { + return TCL_ERROR; + } + if (varc < 1 || varc > 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have one or two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + keyVarObj = varv[0]; + valueVarObj = (varc < 2 ? NULL : varv[1]); + scriptObj = objv[3]; + + /* + * Locate the array variable. + */ + + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + return TCL_ERROR; + } + } + + /* + * Verify that it is indeed an array variable. This test comes after the + * traces; the variable may actually become an array as an effect of said + * traces. + */ + + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + const char *varName = Tcl_GetString(arrayNameObj); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", varName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); + return TCL_ERROR; + } + + /* + * Make a new array search, put it on the stack. + */ + + searchPtr = TclStackAlloc(interp, sizeof(Tcl_ArraySearch)); + Tcl_ArrayObjFirst(interp, arrayNameObj, searchPtr); + + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. + */ + + Tcl_IncrRefCount(keyVarObj); + if (valueVarObj != NULL) { + Tcl_IncrRefCount(valueVarObj); + } + Tcl_IncrRefCount(scriptObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, keyVarObj, + valueVarObj, scriptObj); + return TCL_OK; +} + +/* + * Tcl_ArrayObjFirst + * + * Does not execute the body or set the key/value variables. + * + */ +void +Tcl_ArrayObjFirst( + Tcl_Interp *interp, + Tcl_Obj *arrayObj, + Tcl_ArraySearch *searchPtr) +{ + Var *varPtr; + Var *arrayPtr; + + searchPtr->id = 1; + /* + * Do not turn on VAR_SEARCH_ACTIVE in varPtr->flags. This search is not + * stored in the search list. + */ + searchPtr->nextPtr = NULL; + varPtr = TclObjLookupVarEx(interp, arrayObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + searchPtr->varPtr = varPtr; + searchPtr->arrayNameObj = arrayObj; + searchPtr->flags = TCL_ARRAYSEARCH_FOR_VALUE; + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); +} + +int +Tcl_ArrayObjNext( + Tcl_Interp *interp, + Tcl_ArraySearch *searchPtr, + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr /* Pointer to a variable to have the + * value written into, or NULL.*/ + ) +{ + Tcl_Obj *keyObj; + Tcl_Obj *valueObj = NULL; + Var *varPtr; + int gotValue; + int donerc; + + donerc = 1; + + gotValue = 0; + while (1) { + Tcl_HashEntry *hPtr = searchPtr->nextEntry; + + /* + * The only time hPtr will be non-NULL is when first started. + * nextEntry is set by the Tcl_FirstHashEntry call in the + * call to Tcl_ArrayObjFirst from ArrayForNRCmd. + */ + + if (hPtr != NULL) { + searchPtr->nextEntry = NULL; + } else { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + gotValue = 0; + break; + } + } + varPtr = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr)) { + gotValue = 1; + break; + } + } + + if (!gotValue) { + donerc = 1; + return donerc; + } + + donerc = 0; + + keyObj = VarHashGetKey(varPtr); + *keyPtrPtr = keyObj; + *valuePtrPtr = NULL; + if (searchPtr->flags & TCL_ARRAYSEARCH_FOR_VALUE) { + valueObj = Tcl_ObjGetVar2(interp, searchPtr->arrayNameObj, + keyObj, TCL_LEAVE_ERR_MSG); + *valuePtrPtr = valueObj; + } + + return donerc; +} + +static int +ArrayForLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_ArraySearch *searchPtr = data[0]; + Tcl_Obj *keyObj, *valueObj; + Tcl_Obj *keyVarObj = data[1]; + Tcl_Obj *valueVarObj = data[2]; + Tcl_Obj *scriptObj = data[3]; + int done; + + /* + * Process the result from the previous execution of the script body. + */ + + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"array for\" body line %d)", + Tcl_GetErrorLine(interp))); + } + goto done; + } + + /* + * Get the next mapping from the array. + */ + + keyObj = NULL; + valueObj = NULL; + if (valueVarObj != NULL) { + valueObj = Tcl_NewObj(); + } + done = Tcl_ArrayObjNext (interp, searchPtr, &keyObj, &valueObj); + + result = TCL_OK; + if (done) { + Tcl_ResetResult(interp); + goto done; + } + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto done; + } + if (valueVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto done; + } + } + + /* + * Run the script. + */ + + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, keyVarObj, + valueVarObj, scriptObj); + return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything once the iterating is done. + */ + + done: + TclDecrRefCount(keyVarObj); + if (valueVarObj != NULL) { + TclDecrRefCount(valueVarObj); + } + TclDecrRefCount(scriptObj); + TclStackFree(interp, searchPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * * ArrayStartSearchCmd -- * * This object-based function is invoked to process the "array * startsearch" Tcl command. See the user documentation for details on * what it does. @@ -2903,11 +3188,11 @@ { Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_HashEntry *hPtr; int isNew; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } @@ -2919,21 +3204,23 @@ /* * Make a new array search with a free name. */ - searchPtr = ckalloc(sizeof(ArraySearch)); + searchPtr = ckalloc(sizeof(Tcl_ArraySearch)); hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); if (isNew) { searchPtr->id = 1; varPtr->flags |= VAR_SEARCH_ACTIVE; searchPtr->nextPtr = NULL; } else { - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + searchPtr->id = ((Tcl_ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; + searchPtr->nextPtr = (Tcl_ArraySearch *) Tcl_GetHashValue(hPtr); } searchPtr->varPtr = varPtr; + searchPtr->arrayNameObj = NULL; + searchPtr->flags = 0; searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, &searchPtr->search); Tcl_SetHashValue(hPtr, searchPtr); searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1])); Tcl_IncrRefCount(searchPtr->name); @@ -2968,11 +3255,11 @@ { Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } @@ -3042,11 +3329,11 @@ int objc, Tcl_Obj *const objv[]) { Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } @@ -3121,11 +3408,11 @@ { Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr, *prevPtr; + Tcl_ArraySearch *searchPtr, *prevPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } @@ -3150,19 +3437,19 @@ * Unhook the search from the list of searches associated with the * variable. */ hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr == (Tcl_ArraySearch *) Tcl_GetHashValue(hPtr)) { if (searchPtr->nextPtr) { Tcl_SetHashValue(hPtr, searchPtr->nextPtr); } else { varPtr->flags &= ~VAR_SEARCH_ACTIVE; Tcl_DeleteHashEntry(hPtr); } } else { - for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { + for (prevPtr= (Tcl_ArraySearch *) Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { if (prevPtr->nextPtr == searchPtr) { prevPtr->nextPtr = searchPtr->nextPtr; break; } } @@ -4024,10 +4311,11 @@ { static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, + {"for", NULL, TclCompileArrayForCmd, ArrayForNRCmd, NULL, 0}, {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, @@ -4818,11 +5106,11 @@ * contains an error message. * *---------------------------------------------------------------------- */ -static ArraySearch * +static Tcl_ArraySearch * ParseSearchId( Tcl_Interp *interp, /* Interpreter containing variable. */ const Var *varPtr, /* Array variable search is for. */ Tcl_Obj *varNamePtr, /* Name of array variable that search is * supposed to be for. */ @@ -4830,27 +5118,27 @@ * form "search-num-var" where "num" is a * decimal number and "var" is a variable * name. */ { Interp *iPtr = (Interp *) interp; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; const char *handle = TclGetString(handleObj); char *end; if (varPtr->flags & VAR_SEARCH_ACTIVE) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); /* First look for same (Tcl_Obj *) */ - for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; + for (searchPtr = (Tcl_ArraySearch *) Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { if (searchPtr->name == handleObj) { return searchPtr; } } /* Fallback: do string compares. */ - for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; + for (searchPtr = (Tcl_ArraySearch *) Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { if (strcmp(TclGetString(searchPtr->name), handle) == 0) { return searchPtr; } } @@ -4893,16 +5181,16 @@ DeleteSearches( Interp *iPtr, register Var *arrayVarPtr) /* Variable whose searches are to be * deleted. */ { - ArraySearch *searchPtr, *nextPtr; + Tcl_ArraySearch *searchPtr, *nextPtr; Tcl_HashEntry *sPtr; if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) { sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr); - for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; + for (searchPtr = (Tcl_ArraySearch *) Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); } Index: tests/set-old.test ================================================================== --- tests/set-old.test +++ tests/set-old.test @@ -338,11 +338,11 @@ } {1 {"x" isn't an array}} test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}} +} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg } {1 {"a" isn't an array}} test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} { Index: tests/var.test ================================================================== --- tests/var.test +++ tests/var.test @@ -19,10 +19,12 @@ namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] + +verbose [list line error skip start] testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] testConstraint testsetnoerr [llength [info commands testsetnoerr]] testConstraint memory [llength [info commands memory]] @@ -995,10 +997,124 @@ leaktest {lappend x($i)} } -cleanup { unset -nocomplain i x } -result 0 +unset -nocomplain a k v +test var-23.1 {array command, for loop} -returnCodes error -body { + array for {k v} c d e {} +} -result {wrong # args: should be "array for {keyVarName ?valueVarName?} array script"} +test var-23.2 {array command, for loop} -returnCodes error -body { + array for d {} +} -result {wrong # args: should be "array for {keyVarName ?valueVarName?} array script"} +test var-23.3 {array command, for loop, wrong # of list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v w} a {} +} -result {must have one or two variable names} +test var-23.4 {array command, for loop, no array} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v} a {} +} -result {"a" isn't an array} +test var-23.5 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup { + catch {rename p ""} +} -returnCodes error -body { + apply {{x} { + if {$x==1} { + return [array for {k v} a {}] + } + set a(x) 123 + }} 1 +} -result {"a" isn't an array} +test var-23.6 {array enumeration} -setup { + unset -nocomplain a + unset -nocomplain reslist + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + } + # if someone turns on varPtr->flags |= VAR_SEARCH_ACTIVE + # a segmentation violation will result. + unset a; # this should not cause a segmentation violation. + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 b 2 c 3} +test var-23.7 {array enumeration, without value} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k} a { + lappend reslist $k + } + # there is no guarantee in which order the array contents will be + # returned. + lsort $reslist +} -result {a b c} +test var-23.8 {array enumeration, nested} -setup { + unset -nocomplain a + unset -nocomplain reslist + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k1 v1} a { + lappend reslist $k1 $v1 + set r2 {} + array for {k2 v2} a { + lappend r2 $k2 $v2 + } + lappend reslist [lsort -stride 2 -index 0 $r2] + } + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 3 -index 0 $reslist +} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}} +test var-23.9 {array enumeration, continue} -setup { + unset -nocomplain a + unset -nocomplain reslist + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + if { $k eq {b} } { + continue + } + lappend reslist $k $v + } + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 c 3} +test var-23.10 {array enumeration, break} -setup { + unset -nocomplain a + unset -nocomplain reslist + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + if { $k eq {b} } { + break + } + lappend reslist $k $v + } + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1} catch {namespace delete ns} catch {unset arr} catch {unset v} @@ -1009,10 +1125,11 @@ catch {unset xx} catch {unset x} catch {unset y} catch {unset i} catch {unset a} +catch {unset reslist} catch {unset xxxxx} catch {unset aaaaa} # cleanup ::tcltest::cleanupTests