tclexecute.c

tcl是工具命令语言

     * If the expression evaluated successfully, store a pointer to its
     * value object in resultPtrPtr then restore the old interpreter result.
     * We increment the object's ref count to reflect the reference that we
     * are returning to the caller. We also decrement the ref count of the
     * interpreter's result object after calling Tcl_SetResult since we
     * next store into that field directly.
     */
    
    if (result == TCL_OK) {
	*resultPtrPtr = iPtr->objResultPtr;
	Tcl_IncrRefCount(iPtr->objResultPtr);
	
	Tcl_SetObjResult(interp, saveObjPtr);
    }
    TclDecrRefCount(saveObjPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompEvalObj --
 *
 *	This procedure evaluates the script contained in a Tcl_Obj by 
 *      first compiling it and then passing it to TclExecuteByteCode.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h
 *	(such as TCL_OK), and interp->objResultPtr refers to a Tcl object
 *	that either contains the result of executing the code or an
 *	error message.
 *
 * Side effects:
 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */

int
TclCompEvalObj(interp, objPtr)
    Tcl_Interp *interp;
    Tcl_Obj *objPtr;
{
    register Interp *iPtr = (Interp *) interp;
    register ByteCode* codePtr;		/* Tcl Internal type of bytecode. */
    int oldCount = iPtr->cmdCount;	/* Used to tell whether any commands
					 * at all were executed. */
    char *script;
    int numSrcBytes;
    int result;
    Namespace *namespacePtr;


    /*
     * Check that the interpreter is ready to execute scripts
     */

    if (TclInterpReady(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

    if (iPtr->varFramePtr != NULL) {
        namespacePtr = iPtr->varFramePtr->nsPtr;
    } else {
        namespacePtr = iPtr->globalNsPtr;
    }

    /* 
     * If the object is not already of tclByteCodeType, compile it (and
     * reset the compilation flags in the interpreter; this should be 
     * done after any compilation).
     * Otherwise, check that it is "fresh" enough.
     */

    if (objPtr->typePtr != &tclByteCodeType) {
        recompileObj:
	iPtr->errorLine = 1; 
	result = tclByteCodeType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    return result;
	}
	iPtr->evalFlags = 0;
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
    } else {
	/*
	 * Make sure the Bytecode hasn't been invalidated by, e.g., someone 
	 * redefining a command with a compile procedure (this might make the 
	 * compiled code wrong). 
	 * The object needs to be recompiled if it was compiled in/for a 
	 * different interpreter, or for a different namespace, or for the 
	 * same namespace but with different name resolution rules. 
	 * Precompiled objects, however, are immutable and therefore
	 * they are not recompiled, even if the epoch has changed.
	 *
	 * To be pedantically correct, we should also check that the
	 * originating procPtr is the same as the current context procPtr
	 * (assuming one exists at all - none for global level).  This
	 * code is #def'ed out because [info body] was changed to never
	 * return a bytecode type object, which should obviate us from
	 * the extra checks here.
	 */
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
	        || (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION	/* [Bug: 3412 Pedantic] */
		|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
			iPtr->varFramePtr->procPtr == codePtr->procPtr))
#endif
	        || (codePtr->nsPtr != namespacePtr)
	        || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
            if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
                if ((Interp *) *codePtr->interpHandle != iPtr) {
                    panic("Tcl_EvalObj: compiled script jumped interps");
                }
	        codePtr->compileEpoch = iPtr->compileEpoch;
            } else {
		/*
		 * This byteCode is invalid: free it and recompile
		 */
                tclByteCodeType.freeIntRepProc(objPtr);
		goto recompileObj;
	    }
	}
    }

    /*
     * Execute the commands. If the code was compiled from an empty string,
     * don't bother executing the code.
     */

    numSrcBytes = codePtr->numSrcBytes;
    if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
	/*
	 * Increment the code's ref count while it is being executed. If
	 * afterwards no references to it remain, free the code.
	 */
	
	codePtr->refCount++;
	iPtr->numLevels++;
	result = TclExecuteByteCode(interp, codePtr);
	iPtr->numLevels--;
	codePtr->refCount--;
	if (codePtr->refCount <= 0) {
	    TclCleanupByteCode(codePtr);
	}
    } else {
	result = TCL_OK;
    }

    /*
     * If no commands at all were executed, check for asynchronous
     * handlers so that they at least get one change to execute.
     * This is needed to handle event loops written in Tcl with
     * empty bodies.
     */

    if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
	result = Tcl_AsyncInvoke(interp, result);
    

	/*
	 * If an error occurred, record information about what was being
	 * executed when the error occurred.
	 */
	
	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
	    Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
	}
    }

    /*
     * Set the interpreter's termOffset member to the offset of the
     * character just after the last one executed. We approximate the offset
     * of the last character executed by using the number of characters
     * compiled. 
     */

    iPtr->termOffset = numSrcBytes;
    iPtr->flags &= ~ERR_ALREADY_LOGGED;

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclExecuteByteCode --
 *
 *	This procedure executes the instructions of a ByteCode structure.
 *	It returns when a "done" instruction is executed or an error occurs.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.h
 *	(such as TCL_OK), and interp->objResultPtr refers to a Tcl object
 *	that either contains the result of executing the code or an
 *	error message.
 *
 * Side effects:
 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */
 
static int
TclExecuteByteCode(interp, codePtr)
    Tcl_Interp *interp;		/* Token for command interpreter. */
    ByteCode *codePtr;		/* The bytecode sequence to interpret. */
{
    Interp *iPtr = (Interp *) interp;
    ExecEnv *eePtr = iPtr->execEnvPtr;
    				/* Points to the execution environment. */
    register Tcl_Obj **stackPtr = eePtr->stackPtr;
    				/* Cached evaluation stack base pointer. */
    register int stackTop = eePtr->stackTop;
    				/* Cached top index of evaluation stack. */
    register unsigned char *pc = codePtr->codeStart;
				/* The current program counter. */
    int opnd;			/* Current instruction's operand byte(s). */
    int pcAdjustment;		/* Hold pc adjustment after instruction. */
    int initStackTop = stackTop;/* Stack top at start of execution. */
    ExceptionRange *rangePtr;	/* Points to closest loop or catch exception
				 * range enclosing the pc. Used by various
				 * instructions and processCatch to
				 * process break, continue, and errors. */
    int result = TCL_OK;	/* Return code returned after execution. */
    int storeFlags;
    Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
    char *bytes;
    int length;
    long i = 0;			/* Init. avoids compiler warning. */
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt w;
#endif
    register int cleanup;
    Tcl_Obj *objResultPtr;
    char *part1, *part2;
    Var *varPtr, *arrayPtr;
    CallFrame *varFramePtr = iPtr->varFramePtr;
#ifdef TCL_COMPILE_DEBUG
    int traceInstructions = (tclTraceExec == 3);
    char cmdNameBuf[21];
#endif

    /*
     * This procedure uses a stack to hold information about catch commands.
     * This information is the current operand stack top when starting to
     * execute the code for each catch command. It starts out with stack-
     * allocated space but uses dynamically-allocated storage if needed.
     */

#define STATIC_CATCH_STACK_SIZE 4
    int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
    int *catchStackPtr = catchStackStorage;
    int catchTop = -1;

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 2) {
	PrintByteCodeInfo(codePtr);
	fprintf(stdout, "  Starting stack top=%d\n", eePtr->stackTop);
	fflush(stdout);
    }
    opnd = 0;			/* Init. avoids compiler warning. */       
#endif
    
#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

    /*
     * 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.
     */

    if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
	catchStackPtr = (int *)
	        ckalloc(codePtr->maxExceptDepth * sizeof(int));
    }

    /*
     * Make sure the stack has enough room to execute this ByteCode.
     */

    while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
        GrowEvaluationStack(eePtr); 
        stackPtr = eePtr->stackPtr;
    }

    /*
     * Loop executing instructions until a "done" instruction, a 
     * TCL_RETURN, or some error.
     */

    goto cleanup0;

    
    /*
     * Targets for standard instruction endings; unrolled
     * for speed in the most frequent cases (instructions that 
     * consume up to two stack elements).
     *
     * This used to be a "for(;;)" loop, with each instruction doing
     * its own cleanup.
     */
    
    cleanupV_pushObjResultPtr:
    switch (cleanup) {
        case 0:
	    stackPtr[++stackTop] = (objResultPtr);
	    goto cleanup0;
        default:
	    cleanup -= 2;
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
        case 2: 
        cleanup2_pushObjResultPtr:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
        case 1: 
        cleanup1_pushObjResultPtr:
	    valuePtr = stackPtr[stackTop];
	    TclDecrRefCount(valuePtr);
    }
    stackPtr[stackTop] = objResultPtr;
    goto cleanup0;
    
    cleanupV:
    switch (cleanup) {
        default:
	    cleanup -= 2;
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
        case 2: 
        cleanup2:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
        case 1: 
        cleanup1:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
        case 0:
	    /*
	     * We really want to do nothing now, but this is needed
	     * for some compilers (SunPro CC)
	     */
	    break;
    }

    cleanup0:
    
#ifdef TCL_COMPILE_DEBUG
    ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
    if (traceInstructions) {
	fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
	TclPrintInstruction(codePtr, pc);
	fflush(stdout);
    }
#endif /* TCL_COMPILE_DEBUG */
    
#ifdef TCL_COMPILE_STATS    
    iPtr->stats.instructionCount[*pc]++;
#endif
    switch (*pc) {
    case INST_DONE:
	if (stackTop <= initStackTop) {
	    stackTop--;
	    goto abnormalReturn;
	}
	
	/*
	 * Set the interpreter's object result to point to the 
	 * topmost object from the stack, and check for a possible
	 * [catch]. The stackTop's level and refCount will be handled 
	 * by "processCatch" or "abnormalReturn".
	 */

	valuePtr = stackPtr[stackTop];
	Tcl_SetObjResult(interp, valuePtr);
#ifdef TCL_COMPILE_DEBUG	    
	TRACE_WITH_OBJ(("=> return code=%d, result=", result),
	        iPtr->objResultPtr);
	if (traceInstructions) {
	    fprintf(stdout, "\n");
	}
#endif
	goto checkForCatch;
	
    case INST_PUSH1:
	objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
	TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
	NEXT_INST_F(2, 0, 1);

    case INST_PUSH4:
	objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
	TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
	NEXT_INST_F(5, 0, 1);

    case INST_POP:
	TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
	valuePtr = POP_OBJECT();
	TclDecrRefCount(valuePtr);
	NEXT_INST_F(1, 0, 0);
	
    case INST_DUP:
	objResultPtr = stackPtr[stackTop];
	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(1, 0, 1);

    case INST_OVER:
	opnd = TclGetUInt4AtPtr( pc+1 );
	objResultPtr = stackPtr[ stackTop - opnd ];
	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(5, 0, 1);

    case INST_CONCAT1:
	opnd = TclGetUInt1AtPtr(pc+1);
	{
	    int totalLen = 0;
	    
	    /*
	     * Concatenate strings (with no separators) from the top
	     * opnd items on the stack starting with the deepest item.
	     * First, determine how many characters are needed.
	     */

	    for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
		bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
		if (bytes != NULL) {
		    totalLen += length;