From 75abd6bb662ec2650847427da15a629842b3a63f Mon Sep 17 00:00:00 2001 From: andy Date: Mon, 12 Dec 2016 04:42:52 +0000 Subject: Commit changes received from Brad Lanam via email --- doc/array.n | 7 ++ generic/tcl.decls | 13 +++ generic/tcl.h | 31 ++++++ generic/tclCompCmds.c | 218 ++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 7 +- generic/tclCompile.h | 7 +- generic/tclDecls.h | 17 ++++ generic/tclExecute.c | 99 +++++++++++++++++++ generic/tclInt.h | 3 + generic/tclStubInit.c | 3 + generic/tclVar.c | 268 ++++++++++++++++++++++++++++---------------------- tests/var.test | 52 +++++++++- 12 files changed, 596 insertions(+), 129 deletions(-) diff --git a/doc/array.n b/doc/array.n index 25ad0c6..751c688 100644 --- a/doc/array.n +++ b/doc/array.n @@ -47,6 +47,13 @@ been the return value from a previous invocation of 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 diff --git a/generic/tcl.decls b/generic/tcl.decls index 574b49b..1990457 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2324,6 +2324,19 @@ declare 630 { 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 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index 7984005..ba7f997 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1335,6 +1335,37 @@ typedef struct Tcl_HashSearch { #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 diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5f4c298..6c3b3f9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -49,6 +49,9 @@ static int CompileEachloopCmd(Tcl_Interp *interp, 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. @@ -288,6 +291,221 @@ TclCompileArrayExistsCmd( } 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 diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c0724ee..47093f3 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -522,7 +522,6 @@ InstructionDesc const tclInstructionTable[] = { {"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; @@ -653,7 +652,11 @@ InstructionDesc const tclInstructionTable[] = { {"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}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5ef154e..23939fc 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -821,8 +821,11 @@ typedef struct ByteCode { #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 @@ -1241,7 +1244,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, 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) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b022d3c..a212fd4 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1816,6 +1816,15 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, 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; @@ -2482,6 +2491,9 @@ typedef struct TclStubs { 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; @@ -3774,6 +3786,11 @@ extern const TclStubs *tclStubsPtr; (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) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1f78ead..2ef784c 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -766,6 +766,7 @@ static void IllegalExprOperandType(Tcl_Interp *interp, 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); @@ -798,6 +799,11 @@ static const Tcl_ObjType dictIteratorType = { ReleaseDictIterator, NULL, NULL, NULL }; +static const Tcl_ObjType arrayIteratorType = { + "arrayIterator", + ReleaseArrayIterator, + NULL, NULL, NULL +}; /* *---------------------------------------------------------------------- @@ -837,6 +843,45 @@ ReleaseDictIterator( 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; +} /* *---------------------------------------------------------------------- @@ -4180,6 +4225,60 @@ TEBCresume( 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; diff --git a/generic/tclInt.h b/generic/tclInt.h index 4257ea1..f539d1e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3497,6 +3497,9 @@ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, 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); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2f1bb8b..2bfe27b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1416,6 +1416,9 @@ const TclStubs tclStubs = { Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + 0, /* 631 */ + Tcl_ArrayObjFirst, /* 632 */ + Tcl_ArrayObjNext, /* 633 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index f162d76..60989c1 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -144,34 +144,6 @@ static const char *isArrayElement = #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_Obj *arrayNameObj; /* Name of the array variable in the current - * resolution context. Usually NULL except for - * in "array for". */ - 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: */ @@ -188,7 +160,7 @@ 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, @@ -2836,13 +2808,23 @@ TclArraySet( *---------------------------------------------------------------------- * * ArrayForNRCmd -- + * ArrayForLoopCallback * - * These functions implement the "array for" Tcl command. See the user - * documentation for details on what it does. + * 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. * - * Results: + * ArrayForNRCmd() sets up the Tcl_ArraySearch structure, sets arrayNamePtr + * inside the structure and calls VarHashFirstEntry to start the hash + * iteration. * - * Side effects: + * 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. * *---------------------------------------------------------------------- */ @@ -2857,8 +2839,8 @@ ArrayForNRCmd( Interp *iPtr = (Interp *) interp; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv; - Tcl_Obj *varNameObj; - ArraySearch *searchPtr = NULL; + Tcl_Obj *arrayNameObj; + Tcl_ArraySearch *searchPtr = NULL; Var *varPtr; Var *arrayPtr; int varc; @@ -2888,7 +2870,7 @@ ArrayForNRCmd( return TCL_ERROR; } - varNameObj = objv[2]; + arrayNameObj = objv[2]; keyVarObj = varv[0]; valueVarObj = (varc < 2 ? NULL : varv[1]); scriptObj = objv[3]; @@ -2897,7 +2879,7 @@ ArrayForNRCmd( * Locate the array variable. */ - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); /* @@ -2907,7 +2889,7 @@ ArrayForNRCmd( if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, + 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; @@ -2922,7 +2904,7 @@ ArrayForNRCmd( if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - const char *varName = Tcl_GetString(varNameObj); + const char *varName = Tcl_GetString(arrayNameObj); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", varName)); @@ -2934,19 +2916,8 @@ ArrayForNRCmd( * Make a new array search, put it on the stack. */ - searchPtr = TclStackAlloc(interp, sizeof(ArraySearch)); - 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; - searchPtr->varPtr = varPtr; - searchPtr->arrayNameObj = varNameObj; - searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); + searchPtr = TclStackAlloc(interp, sizeof(Tcl_ArraySearch)); + Tcl_ArrayObjFirst(interp, arrayNameObj, searchPtr); /* * Make sure that these objects (which we need throughout the body of the @@ -2958,7 +2929,6 @@ ArrayForNRCmd( Tcl_IncrRefCount(valueVarObj); } Tcl_IncrRefCount(scriptObj); - Tcl_IncrRefCount(varNameObj); /* * Run the script. @@ -2969,63 +2939,67 @@ ArrayForNRCmd( return TCL_OK; } -static int -ArrayForLoopCallback( - ClientData data[], +/* + * Tcl_ArrayObjFirst + * + * Does not execute the body or set the key/value variables. + * + */ +void +Tcl_ArrayObjFirst( Tcl_Interp *interp, - int result) + Tcl_Obj *arrayObj, + Tcl_ArraySearch *searchPtr) { - Interp *iPtr = (Interp *) interp; - ArraySearch *searchPtr = data[0]; - Tcl_Obj *keyVarObj = data[1]; - Tcl_Obj *valueVarObj = data[2]; - Tcl_Obj *scriptObj = data[3]; - Tcl_Obj *arrayNameObj = searchPtr->arrayNameObj; - Tcl_Obj *keyObj; - Tcl_Obj *valueObj = NULL; Var *varPtr; - int gotValue; + Var *arrayPtr; + searchPtr->id = 1; /* - * Process the result from the previous execution of the script body. + * 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); +} - 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; - } +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; - /* - * Get the next mapping from the array. - */ + 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 - * ArrayForNRCmd + * call to Tcl_ArrayObjFirst from ArrayForNRCmd. */ if (hPtr != NULL) { searchPtr->nextEntry = NULL; - varPtr = VarHashGetValue(hPtr); - if (!TclIsVarUndefined(varPtr)) { - gotValue = 1; - break; - } - } - if (hPtr == NULL) { + } else { hPtr = Tcl_NextHashEntry(&searchPtr->search); if (hPtr == NULL) { gotValue = 0; @@ -3040,27 +3014,81 @@ ArrayForLoopCallback( } if (!gotValue) { - Tcl_ResetResult(interp); - goto done; + 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_ObjGetVar2(interp, arrayNameObj, keyObj, - TCL_LEAVE_ERR_MSG); + valueObj = Tcl_NewObj(); } + done = Tcl_ArrayObjNext (interp, searchPtr, &keyObj, &valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; + 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; - } + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto done; + } } /* @@ -3081,7 +3109,6 @@ ArrayForLoopCallback( TclDecrRefCount(valueVarObj); } TclDecrRefCount(scriptObj); - TclDecrRefCount(arrayNameObj); TclStackFree(interp, searchPtr); return result; } @@ -3163,7 +3190,7 @@ ArrayStartSearchCmd( Var *varPtr; Tcl_HashEntry *hPtr; int isNew; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); @@ -3179,18 +3206,19 @@ ArrayStartSearchCmd( * 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); @@ -3229,7 +3257,7 @@ ArrayAnyMoreCmd( Var *varPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3303,7 +3331,7 @@ ArrayNextElementCmd( { Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3382,7 +3410,7 @@ ArrayDoneSearchCmd( 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"); @@ -3411,7 +3439,7 @@ ArrayDoneSearchCmd( */ 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 { @@ -3419,7 +3447,7 @@ ArrayDoneSearchCmd( 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; @@ -4285,7 +4313,7 @@ TclInitArrayCmd( {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, - {"for", NULL, TclCompileBasic3ArgCmd, ArrayForNRCmd, 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}, @@ -5080,7 +5108,7 @@ Tcl_UpvarObjCmd( *---------------------------------------------------------------------- */ -static ArraySearch * +static Tcl_ArraySearch * ParseSearchId( Tcl_Interp *interp, /* Interpreter containing variable. */ const Var *varPtr, /* Array variable search is for. */ @@ -5092,7 +5120,7 @@ ParseSearchId( * name. */ { Interp *iPtr = (Interp *) interp; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; const char *handle = TclGetString(handleObj); char *end; @@ -5101,14 +5129,14 @@ ParseSearchId( 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; @@ -5155,12 +5183,12 @@ DeleteSearches( 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); diff --git a/tests/var.test b/tests/var.test index d81767a..d211b76 100644 --- a/tests/var.test +++ b/tests/var.test @@ -22,6 +22,8 @@ if {"::tcltest" ni [namespace children]} { ::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]] @@ -1025,9 +1027,8 @@ test var-23.5 {array command, for loop, array doesn't exist yet but has compiler }} 1 } -result {"a" isn't an array} test var-23.6 {array enumeration} -setup { - catch {unset a} - catch {unset reslist} - catch {unset res} + unset -nocomplain a + unset -nocomplain reslist set reslist [list] } -body { array set a {a 1 b 2 c 3} @@ -1042,9 +1043,10 @@ test var-23.6 {array enumeration} -setup { 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 { - catch {unset a} + unset -nocomplain a set reslist [list] } -body { array set a {a 1 b 2 c 3} @@ -1056,7 +1058,8 @@ test var-23.7 {array enumeration, without value} -setup { lsort $reslist } -result {a b c} test var-23.8 {array enumeration, nested} -setup { - catch {unset a} + unset -nocomplain a + unset -nocomplain reslist set reslist [list] } -body { array set a {a 1 b 2 c 3} @@ -1072,6 +1075,44 @@ test var-23.8 {array enumeration, nested} -setup { # 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} @@ -1086,6 +1127,7 @@ catch {unset x} catch {unset y} catch {unset i} catch {unset a} +catch {unset reslist} catch {unset xxxxx} catch {unset aaaaa} -- cgit v0.12