Tcl Source Code

2011-11-22  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclCompileObj): Simplify and de-indent the
	logic so that it is easier to comprehend.

2011-11-22  Jan Nijtmans  <[email protected]>

	* win/tclWinPort.h:   [Bug 2935503]: Windows: file mtime
	* win/tclWinFile.c:  sets wrong time (VS2005+ only)
	* generic/tclTest.c:

2011-11-20  Joe Mistachkin  <[email protected]>

	* tests/thread.test: Remove unnecessary [after] calls from the thread
	tests.  Make error message matching more robust for tests that may

				/* -----------------------------------------*/
    const unsigned char *pc;	/* These fields are used on return TO this */
    ptrdiff_t *catchTop;	/* this level: they record the state when a */
    int cleanup;		/* new codePtr was received for NR */
    Tcl_Obj *auxObjList;	/* execution. */
    int checkInterp;
    CmdFrame cmdFrame;
    void *stack[1];		/* Start of the actual combined catch and obj
				 * stacks; the struct will be expanded as
				 * necessary */
} TEBCdata;

#define TEBC_YIELD() \
    do {								\
	esPtr->tosPtr = tosPtr;						\
	TD->pc = pc;							\
	TD->cleanup = cleanup;						\
	TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \

    } while (0)

#define TEBC_DATA_DIG() \
    do {					\
	pc = TD->pc;				\
	cleanup = TD->cleanup;			\
	tosPtr = esPtr->tosPtr;			\
    } while (0)

#define PUSH_TAUX_OBJ(objPtr) \
    do {							\
	objPtr->internalRep.ptrAndLongRep.ptr = auxObjList;	\
	auxObjList = objPtr;					\
    } while (0)

 * Macros used to trace instruction execution. The macros TRACE,
 * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
 * only used in TRACE* calls to get a string from an object.
 */

#ifdef TCL_COMPILE_DEBUG
#   define TRACE(a) \
    while (traceInstructions) {					\
	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels,	\
		(int) CURR_DEPTH,				\
		(unsigned) (pc - codePtr->codeStart),		\
		GetOpcodeName(pc));				\
	printf a;						\
	break;							\
    }
#   define TRACE_APPEND(a) \
    while (traceInstructions) {		\
	printf a;			\
	break;				\
    }
#   define TRACE_WITH_OBJ(a, objPtr) \
    while (traceInstructions) {					\
	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels,	\
		(int) CURR_DEPTH,				\
		(unsigned) (pc - codePtr->codeStart),		\
		GetOpcodeName(pc));				\
	printf a;						\
	TclPrintObject(stdout, objPtr, 30);			\
	fprintf(stdout, "\n");					\

/*
 * DTrace instruction probe macros.
 */

#define TCL_DTRACE_INST_NEXT() \
    do {								\
	if (TCL_DTRACE_INST_DONE_ENABLED()) {				\
	    if (curInstName) {						\
		TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH,	\
			tosPtr);					\
	    }								\
	    curInstName = tclInstructionTable[*pc].name;		\
	    if (TCL_DTRACE_INST_START_ENABLED()) {			\
		TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH,	\
			tosPtr);					\
	    }								\
	} else if (TCL_DTRACE_INST_START_ENABLED()) {			\
	    TCL_DTRACE_INST_START(tclInstructionTable[*pc].name,	\
			(int) CURR_DEPTH, tosPtr);			\
	}								\
    } while (0)
#define TCL_DTRACE_INST_LAST() \
    do {								\
	if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {		\
	    TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
	}								\
    } while (0)

/*
 * Macro used in this file to save a function call for common uses of
 * TclGetNumberFromObj(). The ANSI C "prototype" is:

	    break;
	}
    }
    if (esPtr->prevPtr) {
	eePtr->execStackPtr = esPtr->prevPtr;
    } else {
	eePtr->execStackPtr = esPtr;
    }
}

void *
TclStackAlloc(
    Tcl_Interp *interp,
    int numBytes)
{

}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileObj --
 *
 *	This procedure compiles the script contained in a Tcl_Obj.
 *
 * Results:
 *	A pointer to the corresponding ByteCode, never NULL.
 *
 * Side effects:
 *	The object is shimmered to bytecode type.
 *
 *----------------------------------------------------------------------
 */

ByteCode *
TclCompileObj(
    Tcl_Interp *interp,

	 */

	codePtr = objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != namespacePtr)
		|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
	    if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
		goto recompileObj;
	    }
	    if ((Interp *) *codePtr->interpHandle != iPtr) {
		Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");
	    }
	    codePtr->compileEpoch = iPtr->compileEpoch;


	}




	/*
	 * Check that any compiled locals do refer to the current proc
	 * environment! If not, recompile.
	 */

	if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) &&
		(codePtr->procPtr == NULL) &&
		(codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){
	    goto recompileObj;


	}

	/*
	 * #280.
	 * Literal sharing fix. This part of the fix is not required by 8.4
	 * nor 8.5, because they eval-direct any literals, so just saving the
	 * argument locations per command in bytecode is enough, embedded

	 *     offset between saved starting line and actual one. Then modify
	 *     the users to adjust the locations they have by this offset.
	 *
	 * (3) Alternative 2: Do not fully recompile, adjust just the location
	 *     information.
	 */

	if (invoker == NULL) {
	    return codePtr;

	} else {

	    Tcl_HashEntry *hePtr =
		    Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
	    ExtCmdLoc *eclPtr;
	    CmdFrame *ctxCopyPtr;
	    int redo;

	    if (!hePtr) {
		return codePtr;
	    }

	    eclPtr = Tcl_GetHashValue(hePtr);
	    redo = 0;
	    ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame));
	    *ctxCopyPtr = *invoker;

	    if (invoker->type == TCL_LOCATION_BC) {
		/*
		 * Note: Type BC => ctx.data.eval.path    is not used.
		 *		    ctx.data.tebc.codePtr used instead
		 */

		TclGetSrcInfoForPc(ctxCopyPtr);
		if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) {
		    /*
		     * The reference made by 'TclGetSrcInfoForPc' is dead.
		     */

		    Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
		    ctxCopyPtr->data.eval.path = NULL;
		}
	    }

	    if (word < ctxCopyPtr->nline) {
		/*
		 * Note: We do not care if the line[word] is -1. This is a
		 * difference and requires a recompile (location changed from
		 * absolute to relative, literal is used fixed and through
		 * variable)
		 *
		 * Example:
		 * test info-32.0 using literal of info-24.8
		 *     (dict with ... vs           set body ...).
		 */

		redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
			    && (eclPtr->start != ctxCopyPtr->line[word]))
			|| ((eclPtr->type == TCL_LOCATION_BC)
			    && (ctxCopyPtr->type == TCL_LOCATION_SOURCE));
	    }

	    TclStackFree(interp, ctxCopyPtr);
	    if (!redo) {
		return codePtr;
	    }
	}
    }

  recompileObj:
    iPtr->errorLine = 1;

    /*
     * TIP #280. Remember the invoker for a moment in the interpreter
     * structures so that the byte code compiler can pick it up when
     * initializing the compilation environment, i.e. the extended location
     * information.
     */

    iPtr->invokeCmdFramePtr = invoker;
    iPtr->invokeWord = word;
    TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
    iPtr->invokeCmdFramePtr = NULL;
    codePtr = objPtr->internalRep.otherValuePtr;
    if (iPtr->varFramePtr->localCachePtr) {
	codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	codePtr->localCachePtr->refCount++;
    }
    return codePtr;

 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */
#define	bcFramePtr	(&TD->cmdFrame)
#define	initCatchTop	((ptrdiff_t *) (&TD->stack[-1]))
#define	initTosPtr	((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
#define esPtr		(iPtr->execEnvPtr->execStackPtr)

int
TclNRExecuteByteCode(
    Tcl_Interp *interp,		/* Token for command interpreter. */
    ByteCode *codePtr)		/* The bytecode sequence to interpret. */
{
    Interp *iPtr = (Interp *) interp;
    TEBCdata *TD;
    int size = sizeof(TEBCdata) - 1
	    + (codePtr->maxStackDepth + codePtr->maxExceptDepth)
		* sizeof(void *);
    int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);

    if (iPtr->execEnvPtr->rewind) {
	return TCL_ERROR;
    }

    codePtr->refCount++;

    /*
     * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
     *
     * The execution uses a unified stack: first a TEBCdata, immediately
     * above it a CmdFrame, then the catch stack, then the execution stack.
     *
     * Make sure the catch stack is large enough to hold the maximum number of
     * catch commands that could ever be executing at the same time (this will
     * be no more than the exception range array's depth). Make sure the
     * execution stack is large enough to execute this ByteCode.
     */

    TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0);
    esPtr->tosPtr = initTosPtr;

    TD->codePtr     = codePtr;
    TD->pc	    = codePtr->codeStart;
    TD->catchTop    = initCatchTop;
    TD->cleanup     = 0;
    TD->auxObjList  = NULL;
    TD->checkInterp = 0;

    /*
     * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
     * every time that we call out from this TD, popped when we return to it.
     */

    bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
	    ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

    /*
     * Push the callback for bytecode execution
     */

    TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
	    NULL, NULL);
    return TCL_OK;
}

static int
TEBCresume(

    int instructionCount = 0;	/* Counter that is used to work out when to
				 * call Tcl_AsyncReady() */
    const char *curInstName;
#ifdef TCL_COMPILE_DEBUG
    int traceInstructions;	/* Whether we are doing instruction-level
				 * tracing or not. */
#endif

    Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
    Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];

#define LOCAL(i)	(&compiledLocals[(i)])
#define TCONST(i)	(constants[(i)])

    /*
     * These macros are just meant to save some global variables that are not
     * used too frequently
     */

    TEBCdata *TD = data[0];
#define auxObjList	(TD->auxObjList)
#define catchTop	(TD->catchTop)
#define codePtr		(TD->codePtr)
#define checkInterp	(TD->checkInterp)
			/* Indicates when a check of interp readyness is
			 * necessary. Set by CACHE_STACK_INFO() */

    /*
     * Globals: variables that store state, must remain valid at all times.
     */

    Tcl_Obj **tosPtr;		/* Cached pointer to top of evaluation
				 * stack. */
    const unsigned char *pc;	/* The current program counter. */

    /*
     * Transfer variables - needed only between opcodes, but not while
     * executing an instruction.
     */

    int cleanup = 0;

		NEXT_INST_V(1, cleanup, 0);
	    }
#endif
	    /*
	     * Push the call's object result and continue execution with the
	     * next instruction.
	     */

	    TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
		    objc, cmdNameBuf), Tcl_GetObjResult(interp));

	    objResultPtr = Tcl_GetObjResult(interp);

	    /*
	     * Reset the interp's result to avoid possible duplications of
	     * large objects [Bug 781585]. We do not call Tcl_ResetResult to
	     * avoid any side effects caused by the resetting of errorInfo and
	     * errorCode [Bug 804681], which are not needed here. We chose
	     * instead to manipulate the interp's object result directly.
	     *
	     * Note that the result object is now in objResultPtr, it keeps
	     * the refCount it had in its role of iPtr->objResultPtr.
	     */

	    TclNewObj(objPtr);
	    Tcl_IncrRefCount(objPtr);
	    iPtr->objResultPtr = objPtr;
	    NEXT_INST_V(0, cleanup, -1);
	}

	/*
	 * Result not TCL_OK: fall through
	 */
    }

    if (iPtr->execEnvPtr->rewind) {
	result = TCL_ERROR;
	goto abnormalReturn;
    }

    if (result != TCL_OK) {
	pc--;

	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;
	if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) {
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	    DECACHE_STACK_INFO();
	    IllegalExprOperandType(interp, pc, valuePtr);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

	if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) {
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
		    (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
	    DECACHE_STACK_INFO();
	    IllegalExprOperandType(interp, pc, value2Ptr);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

	if (*pc == INST_LOR) {
	    iResult = (i1 || i2);
	} else {
	    iResult = (i1 && i2);

	    if (TclIsPureByteArray(valuePtr)
		    && TclIsPureByteArray(value2Ptr)) {
		s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
		s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
		memCmpFn = memcmp;
	    } else if (((valuePtr->typePtr == &tclStringType)
		    && (value2Ptr->typePtr == &tclStringType))) {
		/*
		 * Do a unicode-specific comparison if both of the args are of
		 * String type. If the char length == byte length, we can do a
		 * memcmp. In benchmark testing this proved the most efficient
		 * check between the unicode and string comparison operations.
		 */

	    goto gotError;
	}
	/* TODO: Consider peephole opt. */
	objResultPtr = TCONST(!b);
	NEXT_INST_F(1, 1, 1);
    }

    case INST_BITNOT:
	valuePtr = OBJ_AT_TOS;
	if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
		|| (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
	    /*
	     * ... ~$NonInteger => raise an error.
	     */

	/*
	 * Division by zero in an expression. Control only reaches this point
	 * by "goto divideByZero".
	 */

    divideByZero:
	DECACHE_STACK_INFO();
	Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
	CACHE_STACK_INFO();
	goto gotError;

	/*
	 * Exponentiation of zero by negative number in an expression. Control
	 * only reaches this point by "goto exponOfZero".
	 */

    exponOfZero:
	DECACHE_STACK_INFO();
	Tcl_SetResult(interp, "exponentiation of zero by negative power",
		TCL_STATIC);
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
		"exponentiation of zero by negative power", NULL);
	CACHE_STACK_INFO();

	/*

	/*
	 * Clear all expansions that may have started after the last
	 * INST_BEGIN_CATCH.
	 */

	while (auxObjList) {
	    if ((catchTop != initCatchTop)
		    && (*catchTop > (ptrdiff_t)
			auxObjList->internalRep.ptrAndLongRep.value)) {
		break;
	    }
	    POP_TAUX_OBJ();
	}

	/*
	 * We must not catch if the script in progress has been canceled with

    Interp *iPtr,
    int *lenPtr)
{
    CmdFrame *cfPtr = iPtr->cmdFramePtr;
    ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;

    return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
	    codePtr, lenPtr, NULL);
}

void
TclGetSrcInfoForPc(
    CmdFrame *cfPtr)
{
    ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;

    }
}

static const char *
GetSrcInfoForPc(
    const unsigned char *pc,	/* The program counter value for which to
				 * return the closest command's source info.
				 * This points within a bytecode instruction
				 * in codePtr's code. */
    ByteCode *codePtr,		/* The bytecode sequence in which to look up
				 * the command source for the pc. */
    int *lengthPtr,		/* If non-NULL, the location where the length
				 * of the command's source should be stored.
				 * If NULL, no length is stored. */
    const unsigned char **pcBeg)/* If non-NULL, the bytecode location
				 * where the current instruction starts.

		bestSrcOffset = srcOffset;
		bestSrcLength = srcLen;
	    }
	}
    }

    if (pcBeg != NULL) {
	const unsigned char *curr, *prev;

	/*
	 * Walk from beginning of command or BC to pc, by complete
	 * instructions. Stop when crossing pc; keep previous.
	 */

	curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist);


	prev = curr;
	while (curr <= pc) {
	    prev = curr;
	    curr += tclInstructionTable[*curr].numBytes;
	}
	*pcBeg = prev;
    }

    if (bestDist == INT_MAX) {
	return NULL;
    }

    if (lengthPtr != NULL) {