Tcl Source Code

				 *     tightly packed fields, where the alloc,
				 *     used and signum flags are packed into a
				 *     single word with everything else hung
				 *     off the pointer. */
	    void *ptr;
	    unsigned long value;
	} ptrAndLongRep;
	struct {
	    long int1;
	    long int2;
	} twoIntValue;
    } internalRep;
} Tcl_Obj;

/*
 * Macros to increment and decrement a Tcl_Obj's reference count, and to test
 * whether an object is shared (i.e. has reference count > 1). Note: clients
 * should use Tcl_DecrRefCount() when they are finished using an object, and

				 * compiled. */
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Token *varTokenPtr, *dataTokenPtr;
    int isScalar, localIndex, code = TCL_OK;
    int isDataLiteral, isDataValid, isDataEven, len;
    int keyVar, valVar, infoIndex;
    int fwd, offsetBack, offsetFwd;
    Tcl_Obj *literalObj;
    ForeachInfo *infoPtr;

    if (parsePtr->numWords != 3) {
	return TCL_ERROR;
    }

    PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
	    &localIndex, &isScalar, 1);
    if (!isScalar) {
	code = TCL_ERROR;
	goto done;
    }

    /*
     * Special case: literal empty value argument is just an "ensure array"
     * operation.
     */

    if (isDataEven && len == 0) {
	if (localIndex >= 0) {

	    TclAdjustStackDepth(1, envPtr);
	    TclEmitOpcode(  INST_POP,				envPtr);
	}
	PushStringLiteral(envPtr, "");
	goto done;
    }

    if (localIndex < 0) {
	/*
	 * a non-local variable: upvar from a local one! This consumes the
	 * variable name that was left at stacktop.
	 */
	
	localIndex = AnonymousLocal(envPtr);
	PushStringLiteral(envPtr, "0");
	TclEmitInstInt4(INST_REVERSE, 2,        		envPtr);
	TclEmitInstInt4(INST_UPVAR, localIndex, 		envPtr);
	TclEmitOpcode(INST_POP,          			envPtr);
    }
    
    /*
     * Prepare for the internal foreach.
     */



    keyVar = AnonymousLocal(envPtr);
    valVar = AnonymousLocal(envPtr);

    infoPtr = ckalloc(sizeof(ForeachInfo));
    infoPtr->numLists = 1;


    infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int));
    infoPtr->varLists[0]->numVars = 2;
    infoPtr->varLists[0]->varIndexes[0] = keyVar;
    infoPtr->varLists[0]->varIndexes[1] = valVar;
    infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);

    /*
     * Start issuing instructions to write to the array.

	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
	TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR,		envPtr);
	TclEmitInt4(		0,				envPtr);
	TclAdjustStackDepth(-1, envPtr);
	fwd = CurrentOffset(envPtr) - offsetFwd;
	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
    }




    TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex,	envPtr);
    TclEmitInstInt1(INST_JUMP_TRUE1, 7,			envPtr);
    TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex,	envPtr);
    TclEmitInstInt4(INST_FOREACH_START, infoIndex,	envPtr);
    offsetBack = CurrentOffset(envPtr);



    Emit14Inst(	INST_LOAD_SCALAR, keyVar,		envPtr);
    Emit14Inst(	INST_LOAD_SCALAR, valVar,		envPtr);
    Emit14Inst(	INST_STORE_ARRAY, localIndex,		envPtr);
    TclEmitOpcode(	INST_POP,			envPtr);
    infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */




    TclEmitOpcode( INST_FOREACH_STEP,			envPtr);


    TclEmitOpcode( INST_FOREACH_END,			envPtr);


    TclAdjustStackDepth(-3, envPtr);














    PushStringLiteral(envPtr,	"");




    done:
    Tcl_DecrRefCount(literalObj);
    return code;
}

int
TclCompileArrayUnsetCmd(
    Tcl_Interp *interp,		/* Used for looking up stuff. */

    int collect)		/* Select collecting or accumulating mode
				 * (TCL_EACH_*) */
{
    Proc *procPtr = envPtr->procPtr;
    ForeachInfo *infoPtr;	/* Points to the structure describing this
				 * foreach command. Stored in a AuxData
				 * record in the ByteCode. */




    int collectVar = -1;	/* Index of temp var holding the result var
				 * index. */
    
    Tcl_Token *tokenPtr, *bodyTokenPtr;


    int jumpBackOffset, infoIndex, range;
    int numWords, numLists, numVars, loopIndex, i, j, code;
    DefineLineInformation;	/* TIP #280 */

    /*
     * We parse the variable list argument words and create two arrays:
     *    varcList[i] is number of variables in i-th var list.
     *    varvList[i] points to array of var names in i-th var list.
     */

		code = TCL_ERROR;
		goto done;
	    }
	}
	loopIndex++;
    }

    /*
     * We will compile the foreach command.
     */

    if (collect == TCL_EACH_COLLECT) {
	collectVar = AnonymousLocal(envPtr);
	if (collectVar < 0) {
	    return TCL_ERROR;
	}
    }
	    










    code = TCL_OK;









    /*
     * Create and initialize the ForeachInfo and ForeachVarList data
     * structures describing this command. Then create a AuxData record
     * pointing to the ForeachInfo structure.
     */

    infoPtr = ckalloc(sizeof(ForeachInfo)
	    + (numLists - 1) * sizeof(ForeachVarList *));
    infoPtr->numLists = numLists;


    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	ForeachVarList *varListPtr;

	numVars = varcList[loopIndex];
	varListPtr = ckalloc(sizeof(ForeachVarList)
		+ (numVars - 1) * sizeof(int));
	varListPtr->numVars = numVars;
	for (j = 0;  j < numVars;  j++) {
	    const char *varName = varvList[loopIndex][j];
	    int nameChars = strlen(varName);

	    varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
		    nameChars, /*create*/ 1, envPtr);
	}
	infoPtr->varLists[loopIndex] = varListPtr;
    }
    infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);

    /*


     * Evaluate each value list and leave it on stack.




     */


    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr = TokenAfter(tokenPtr)) {
	if ((i%2 == 0) && (i > 0)) {
	    CompileWord(envPtr, tokenPtr, interp, i);




	}
    }

    /*
     * Create temporary variable to capture return values from loop body.
     */
     
    if (collect == TCL_EACH_COLLECT) {
	PushStringLiteral(envPtr, "");
	Emit14Inst(		INST_STORE_SCALAR, collectVar,	envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }




    TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);

    









    /*
     * Inline compile the loop body.
     */

    range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);

    ExceptionRangeStarts(envPtr, range);
    BODY(bodyTokenPtr, numWords - 1);
    ExceptionRangeEnds(envPtr, range);
    
    if (collect == TCL_EACH_COLLECT) {
	Emit14Inst(		INST_LAPPEND_SCALAR, collectVar,envPtr);
    }
    TclEmitOpcode(		INST_POP,			envPtr);

    /*





     * Bottom of loop code: assign each loop variable and check whether







     * to terminate the loop. Set the loop's break target. 


     */





    ExceptionRangeTarget(envPtr, range, continueOffset);

    TclEmitOpcode(INST_FOREACH_STEP, envPtr);



















    ExceptionRangeTarget(envPtr, range, breakOffset);
    TclFinalizeLoopExceptionRange(envPtr, range);
    TclEmitOpcode(INST_FOREACH_END, envPtr);
    TclAdjustStackDepth(-(numLists+2), envPtr);

    /*
     * Set the jumpback distance from INST_FOREACH_STEP to the start of the
     * body's code. Misuse loopCtTemp for storing the jump size.
     */
    
    jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset -
	    envPtr->exceptArrayPtr[range].codeOffset;
    infoPtr->loopCtTemp = -jumpBackOffset;

    /*
     * The command's result is an empty string if not collecting, or the
     * list of results from evaluating the loop body.
     */

    if (collect == TCL_EACH_COLLECT) {
	Emit14Inst(		INST_LOAD_SCALAR, collectVar,	envPtr);
	TclEmitInstInt1(INST_UNSET_SCALAR, 0,			envPtr);
	TclEmitInt4(		collectVar,			envPtr);
    } else {
	PushStringLiteral(envPtr, "");
    }
    
    done:
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	if (varvList[loopIndex] != NULL) {
	    ckfree(varvList[loopIndex]);
	}
    }
    TclStackFree(interp, (void *)varvList);
    TclStackFree(interp, varcList);

	 * list and pushes that resulting list onto the stack.
	 * Stack: ... list1 list2 => ... [lconcat list1 list2] */

    {"expandDrop",       1,    0,          0,	{OPERAND_NONE}},
	/* Drops an element from the auxiliary stack, popping stack elements
	 * until the matching stack depth is reached. */

    /* New foreach implementation */
    {"foreach_start",	  5,   +2,          1,	{OPERAND_AUX4}},
	/* Initialize execution of a foreach loop. Operand is aux data index
	 * of the ForeachInfo structure for the foreach command. It pushes 2
	 * elements which hold runtime params for foreach_step, they are later
	 * dropped by foreach_end together with the value lists. */ 
    {"foreach_step",	  1,    0,         0,	{OPERAND_NONE}},
	/* "Step" or begin next iteration of foreach loop. */
    {"foreach_end",	  1,    0,         0,	{OPERAND_NONE}},

    {NULL, 0, 0, 0, {OPERAND_NONE}}
};

/*
 * Prototypes for procedures defined later in this file:
 */

#define INST_TRY_CVT_TO_NUMERIC		64

/* Opcodes 65 to 66 */
#define INST_BREAK			65
#define INST_CONTINUE			66

/* Opcodes 67 to 68 */
#define INST_FOREACH_START4		67 /* DEPRECATED */
#define INST_FOREACH_STEP4		68 /* DEPRECATED */

/* Opcodes 69 to 72 */
#define INST_BEGIN_CATCH4		69
#define INST_END_CATCH			70
#define INST_PUSH_RESULT		71
#define INST_PUSH_RETURN_CODE		72

#define INST_INVOKE_REPLACE		163

#define INST_LIST_CONCAT		164

#define INST_EXPAND_DROP		165

/* New foreach implementation */

#define INST_FOREACH_START              166
#define INST_FOREACH_STEP               167
#define INST_FOREACH_END                168

/* The last opcode */
#define LAST_INST_OPCODE		168

/*
 * 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
 * and unsigned integers of length one and four bytes. The unsigned integers
 * are used for indexes or for, e.g., the count of objects to push in a "push"

	Var *iterVarPtr, *listVarPtr;
	Tcl_Obj *oldValuePtr, *listPtr, **elements;
	ForeachVarList *varListPtr;
	int numLists, iterNum, listTmpIndex, listLen, numVars;
	int varIndex, valIndex, continueLoop, j, iterTmpIndex;
	long i;

    case INST_FOREACH_START4: /* DEPRECATED */
	/*
	 * Initialize the temporary local var that holds the count of the
	 * number of iterations of the loop body to -1.
	 */

	opnd = TclGetUInt4AtPtr(pc+1);
	infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;

	pc += 5;
	TCL_DTRACE_INST_NEXT();
#else
	NEXT_INST_F(5, 0, 0);
#endif

    case INST_FOREACH_STEP4: /* DEPRECATED */
	/*
	 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
	 * the next value list element to each loop var.
	 */

	opnd = TclGetUInt4AtPtr(pc+1);
	infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;

	pc += 5;
	if (*pc == INST_JUMP_FALSE1) {
	    NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
	} else {
	    NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
	}

    }
    {
	ForeachInfo *infoPtr;
	Tcl_Obj *listPtr, **elements, *tmpPtr;
	ForeachVarList *varListPtr;
	int numLists, iterMax, listLen, numVars;
	int iterTmp, iterNum, listTmpDepth;
	int varIndex, valIndex, j;
	long i;

    case INST_FOREACH_START:
	/*
	 * Initialize the data for the looping construct, pushing the
	 * corresponding Tcl_Objs to the stack.
	 */

	
	opnd = TclGetUInt4AtPtr(pc+1);
	infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
	numLists = infoPtr->numLists;

	/*
	 * Compute the number of iterations that will be run: iterMax
	 */

	iterMax = 0;
	listTmpDepth = numLists-1;
	for (i = 0;  i < numLists;  i++) {
	    varListPtr = infoPtr->varLists[i];
	    numVars = varListPtr->numVars;
	    listPtr = OBJ_AT_DEPTH(listTmpDepth);
	    if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
		TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
			opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
		goto gotError;
	    }
	    if (Tcl_IsShared(listPtr)) {
		objPtr = TclListObjCopy(NULL, listPtr);
		Tcl_IncrRefCount(objPtr);
		Tcl_DecrRefCount(listPtr);
		OBJ_AT_DEPTH(listTmpDepth) = objPtr;
	    }
	    iterTmp = (listLen + (numVars - 1))/numVars;
	    if (iterTmp > iterMax) {
		iterMax = iterTmp;
	    }
	    listTmpDepth--;
	}
	
	/*
	 * Store the iterNum and iterMax in a single Tcl_Obj; we keep a
	 * nul-string obj with the pointer stored in the ptrValue so that the
	 * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but
	 * it will never leave this scope and is read-only.
	 */

	TclNewObj(tmpPtr);
	tmpPtr->internalRep.twoIntValue.int1 = 0;
	tmpPtr->internalRep.twoIntValue.int2 = iterMax;
	PUSH_OBJECT(tmpPtr); /* iterCounts object */
		
	/*
	 * Store a pointer to the ForeachInfo struct; same dirty trick
	 * as above 
	 */
	
	TclNewObj(tmpPtr);
	tmpPtr->internalRep.otherValuePtr = infoPtr;
	PUSH_OBJECT(tmpPtr); /* infoPtr object */

	/*
	 * Jump directly to the INST_FOREACH_STEP instruction; the C code just
	 * falls through.
	 */ 

	pc += 5 - infoPtr->loopCtTemp;
	
    case INST_FOREACH_STEP:
	/*
	 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
	 * the next value list element to each loop var.
	 */

	tmpPtr = OBJ_AT_TOS;
	infoPtr = tmpPtr->internalRep.otherValuePtr;
	numLists = infoPtr->numLists;

	tmpPtr = OBJ_AT_DEPTH(1);
	iterNum = tmpPtr->internalRep.twoIntValue.int1;
	iterMax = tmpPtr->internalRep.twoIntValue.int2;

	/*
	 * If some list still has a remaining list element iterate one more
	 * time. Assign to var the next element from its value list.
	 */
	    
	if (iterNum < iterMax) {
	    /*
	     * Set the variables and jump back to run the body
	     */

	    tmpPtr->internalRep.twoIntValue.int1 = iterNum + 1;
	    
	    listTmpDepth = numLists + 1;

	    for (i = 0;  i < numLists;  i++) {
		varListPtr = infoPtr->varLists[i];
		numVars = varListPtr->numVars;

		listPtr = OBJ_AT_DEPTH(listTmpDepth);
		TclListObjGetElements(interp, listPtr, &listLen, &elements);

		valIndex = (iterNum * numVars);
		for (j = 0;  j < numVars;  j++) {
		    if (valIndex >= listLen) {
			TclNewObj(valuePtr);
		    } else {
			valuePtr = elements[valIndex];
		    }

		    varIndex = varListPtr->varIndexes[j];
		    varPtr = LOCAL(varIndex);
		    while (TclIsVarLink(varPtr)) {
			varPtr = varPtr->value.linkPtr;
		    }
		    if (TclIsVarDirectWritable(varPtr)) {
			value2Ptr = varPtr->value.objPtr;
			if (valuePtr != value2Ptr) {
			    if (value2Ptr != NULL) {
				TclDecrRefCount(value2Ptr);
			    }
			    varPtr->value.objPtr = valuePtr;
			    Tcl_IncrRefCount(valuePtr);
			}
		    } else {
			DECACHE_STACK_INFO();
			if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
				valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
			    CACHE_STACK_INFO();
			    TRACE_WITH_OBJ((
				    "%u => ERROR init. index temp %d: ",
				    opnd,varIndex), Tcl_GetObjResult(interp));
			    goto gotError;
			}
			CACHE_STACK_INFO();
		    }
		    valIndex++;
		}
		listTmpDepth--;
	    }
	    /* loopCtTemp being 'misused' for storing the jump size */
	    NEXT_INST_F(infoPtr->loopCtTemp, 0, 0);
	}

	/*
	 * FALL THROUGH
	 */
	pc++;

    case INST_FOREACH_END:
	/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
	tmpPtr = OBJ_AT_TOS;
	infoPtr = tmpPtr->internalRep.otherValuePtr;
	numLists = infoPtr->numLists;
	NEXT_INST_V(1, numLists+2, 0);
    }

    case INST_BEGIN_CATCH4:
	/*
	 * Record start of the catch command with exception range index equal
	 * to the operand. Push the current stack depth onto the special catch
	 * stack.