diff options
-rw-r--r-- | doc/array.n | 7 | ||||
-rw-r--r-- | generic/tcl.decls | 13 | ||||
-rw-r--r-- | generic/tcl.h | 31 | ||||
-rw-r--r-- | generic/tclCompCmds.c | 218 | ||||
-rw-r--r-- | generic/tclCompile.c | 7 | ||||
-rw-r--r-- | generic/tclCompile.h | 7 | ||||
-rw-r--r-- | generic/tclDecls.h | 17 | ||||
-rw-r--r-- | generic/tclExecute.c | 99 | ||||
-rw-r--r-- | generic/tclInt.h | 3 | ||||
-rw-r--r-- | generic/tclStubInit.c | 3 | ||||
-rw-r--r-- | generic/tclVar.c | 370 | ||||
-rw-r--r-- | tests/set-old.test | 2 | ||||
-rw-r--r-- | tests/var.test | 117 |
13 files changed, 848 insertions, 46 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 a8c68a6..246a873 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 074b1d5..b474360 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 ca8ad70..0ce1cb1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3499,6 +3499,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 5ab6e8b..98bde2e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -144,36 +144,12 @@ 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_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); @@ -184,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, @@ -2831,6 +2807,315 @@ TclArraySet( /* *---------------------------------------------------------------------- * + * 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 @@ -2905,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"); @@ -2921,17 +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); @@ -2970,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"); @@ -3044,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"); @@ -3123,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"); @@ -3152,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 { @@ -3160,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; @@ -4026,6 +4313,7 @@ TclInitArrayCmd( {"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}, @@ -4820,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. */ @@ -4832,7 +5120,7 @@ ParseSearchId( * name. */ { Interp *iPtr = (Interp *) interp; - ArraySearch *searchPtr; + Tcl_ArraySearch *searchPtr; const char *handle = TclGetString(handleObj); char *end; @@ -4841,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; @@ -4895,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/set-old.test b/tests/set-old.test index 309abaf..b2e7aa6 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -340,7 +340,7 @@ 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 diff --git a/tests/var.test b/tests/var.test index 9816d98..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]] @@ -997,6 +999,120 @@ test var-22.2 {leak in parsedVarName} -constraints memory -body { 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} @@ -1011,6 +1127,7 @@ catch {unset x} catch {unset y} catch {unset i} catch {unset a} +catch {unset reslist} catch {unset xxxxx} catch {unset aaaaa} |