tclcompile.c

tcl是工具命令语言

    for ( ;  count > 0;  count--, tokenPtr++) {
	switch (tokenPtr->type) {
	    case TCL_TOKEN_TEXT:
		Tcl_DStringAppend(&textBuffer, tokenPtr->start,
			tokenPtr->size);
		break;

	    case TCL_TOKEN_BS:
		length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
			buffer);
		Tcl_DStringAppend(&textBuffer, buffer, length);
		break;

	    case TCL_TOKEN_COMMAND:
		/*
		 * Push any accumulated chars appearing before the command.
		 */
		
		if (Tcl_DStringLength(&textBuffer) > 0) {
		    int literal;
		    
		    literal = TclRegisterLiteral(envPtr,
			    Tcl_DStringValue(&textBuffer),
			    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
		    TclEmitPush(literal, envPtr);
		    numObjsToConcat++;
		    Tcl_DStringFree(&textBuffer);
		}
		
		code = TclCompileScript(interp, tokenPtr->start+1,
			tokenPtr->size-2, /*nested*/ 0,	envPtr);
		if (code != TCL_OK) {
		    goto error;
		}
		numObjsToConcat++;
		break;

	    case TCL_TOKEN_VARIABLE:
		/*
		 * Push any accumulated chars appearing before the $<var>.
		 */
		
		if (Tcl_DStringLength(&textBuffer) > 0) {
		    int literal;
		    
		    literal = TclRegisterLiteral(envPtr,
			    Tcl_DStringValue(&textBuffer),
			    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
		    TclEmitPush(literal, envPtr);
		    numObjsToConcat++;
		    Tcl_DStringFree(&textBuffer);
		}
		
		/*
		 * Determine how the variable name should be handled: if it contains 
		 * any namespace qualifiers it is not a local variable (localVarName=-1);
		 * if it looks like an array element and the token has a single component, 
		 * it should not be created here [Bug 569438] (localVarName=0); otherwise, 
		 * the local variable can safely be created (localVarName=1).
		 */
		
		name = tokenPtr[1].start;
		nameBytes = tokenPtr[1].size;
		localVarName = -1;
		if (envPtr->procPtr != NULL) {
		    localVarName = 1;
		    for (i = 0, p = name;  i < nameBytes;  i++, p++) {
			if ((*p == ':') && (i < (nameBytes-1))
			        && (*(p+1) == ':')) {
			    localVarName = -1;
			    break;
			} else if ((*p == '(')
			        && (tokenPtr->numComponents == 1) 
				&& (*(name + nameBytes - 1) == ')')) {
			    localVarName = 0;
			    break;
			}
		    }
		}

		/*
		 * Either push the variable's name, or find its index in
		 * the array of local variables in a procedure frame. 
		 */

		localVar = -1;
		if (localVarName != -1) {
		    localVar = TclFindCompiledLocal(name, nameBytes, 
			        localVarName, /*flags*/ 0, envPtr->procPtr);
		}
		if (localVar < 0) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
			    envPtr); 
		}

		/*
		 * Emit instructions to load the variable.
		 */
		
		if (tokenPtr->numComponents == 1) {
		    if (localVar < 0) {
			TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
		    } else if (localVar <= 255) {
			TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
			        envPtr);
		    } else {
			TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
				envPtr);
		    }
		} else {
		    code = TclCompileTokens(interp, tokenPtr+2,
			    tokenPtr->numComponents-1, envPtr);
		    if (code != TCL_OK) {
			char errorBuffer[150];
			sprintf(errorBuffer,
			        "\n    (parsing index for array \"%.*s\")",
				((nameBytes > 100)? 100 : nameBytes), name);
			Tcl_AddObjErrorInfo(interp, errorBuffer, -1);
			goto error;
		    }
		    if (localVar < 0) {
			TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
		    } else if (localVar <= 255) {
			TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
			        envPtr);
		    } else {
			TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
			        envPtr);
		    }
		}
		numObjsToConcat++;
		count -= tokenPtr->numComponents;
		tokenPtr += tokenPtr->numComponents;
		break;

	    default:
		panic("Unexpected token type in TclCompileTokens");
	}
    }

    /*
     * Push any accumulated characters appearing at the end.
     */

    if (Tcl_DStringLength(&textBuffer) > 0) {
	int literal;

	literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
	        Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
	TclEmitPush(literal, envPtr);
	numObjsToConcat++;
    }

    /*
     * If necessary, concatenate the parts of the word.
     */

    while (numObjsToConcat > 255) {
	TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
	numObjsToConcat -= 254;	/* concat pushes 1 obj, the result */
    }
    if (numObjsToConcat > 1) {
	TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
    }

    /*
     * If the tokens yielded no instructions, push an empty string.
     */
    
    if (envPtr->codeNext == entryCodeNext) {
	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
	        envPtr);
    }
    Tcl_DStringFree(&textBuffer);
    return TCL_OK;

    error:
    Tcl_DStringFree(&textBuffer);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileCmdWord --
 *
 *	Given an array of parse tokens for a word containing one or more Tcl
 *	commands, emit inline instructions to execute them. This procedure
 *	differs from TclCompileTokens in that a simple word such as a loop
 *	body enclosed in braces is not just pushed as a string, but is
 *	itself parsed into tokens and compiled.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *	
 * Side effects:
 *	Instructions are added to envPtr to execute the tokens at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileCmdWord(interp, tokenPtr, count, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens
				 * for a command word to compile inline. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    int code;

    /*
     * Handle the common case: if there is a single text token, compile it
     * into an inline sequence of instructions.
     */
    
    if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
	code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
	        /*nested*/ 0, envPtr);
	return code;
    }

    /*
     * Multiple tokens or the single token involves substitutions. Emit
     * instructions to invoke the eval command procedure at runtime on the
     * result of evaluating the tokens.
     */

    code = TclCompileTokens(interp, tokenPtr, count, envPtr);
    if (code != TCL_OK) {
	return code;
    }
    TclEmitOpcode(INST_EVAL_STK, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileExprWords --
 *
 *	Given an array of parse tokens representing one or more words that
 *	contain a Tcl expression, emit inline instructions to execute the
 *	expression. This procedure differs from TclCompileExpr in that it
 *	supports Tcl's two-level substitution semantics for expressions that
 *	appear as command words.
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *	
 * Side effects:
 *	Instructions are added to envPtr to execute the expression.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Points to first in an array of word
				 * tokens tokens for the expression to
				 * compile inline. */
    int numWords;		/* Number of word tokens starting at
				 * tokenPtr. Must be at least 1. Each word
				 * token contains one or more subtokens. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_Token *wordPtr;
    int numBytes, i, code;
    CONST char *script;

    code = TCL_OK;

    /*
     * If the expression is a single word that doesn't require
     * substitutions, just compile it's string into inline instructions.
     */

    if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
	/*
	 * Temporarily overwrite the character just after the end of the
	 * string with a 0 byte.
	 */

	script = tokenPtr[1].start;
	numBytes = tokenPtr[1].size;
	code = TclCompileExpr(interp, script, numBytes, envPtr);
	return code;
    }
   
    /*
     * Emit code to call the expr command proc at runtime. Concatenate the
     * (already substituted once) expr tokens with a space between each.
     */

    wordPtr = tokenPtr;
    for (i = 0;  i < numWords;  i++) {
	code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
                envPtr);
	if (code != TCL_OK) {
	    break;
	}
	if (i < (numWords - 1)) {
	    TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
	            envPtr);
	}
	wordPtr += (wordPtr->numComponents + 1);
    }
    if (code == TCL_OK) {
	int concatItems = 2*numWords - 1;
	while (concatItems > 255) {
	    TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
	    concatItems -= 254;
	}
	if (concatItems > 1) {
	    TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
	}
	TclEmitOpcode(INST_EXPR_STK, envPtr);
    }

    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitByteCodeObj --
 *
 *	Create a ByteCode structure and initialize it from a CompileEnv
 *	compilation environment structure. The ByteCode structure is
 *	smaller and contains just that information needed to execute
 *	the bytecode instructions resulting from compiling a Tcl script.
 *	The resulting structure is placed in the specified object.
 *
 * Results:
 *	A newly constructed ByteCode object is stored in the internal
 *	representation of the objPtr.
 *
 * Side effects:
 *	A single heap object is allocated to hold the new ByteCode structure
 *	and its code, object, command location, and aux data arrays. Note
 *	that "ownership" (i.e., the pointers to) the Tcl objects and aux
 *	data items will be handed over to the new ByteCode structure from
 *	the CompileEnv structure.
 *
 *----------------------------------------------------------------------
 */

void
TclInitByteCodeObj(objPtr, envPtr)
    Tcl_Obj *objPtr;		 /* Points object that should be
				  * initialized, and whose string rep
				  * contains the source code. */
    register CompileEnv *envPtr; /* Points to the CompileEnv structure from
				  * which to create a ByteCode structure. */
{
    register ByteCode *codePtr;
    size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
    size_t auxDataArrayBytes, structureSize;
    register unsigned char *p;
    unsigned char *nextPtr;
    int numLitObjects = envPtr->literalArrayNext;
    Namespace *namespacePtr;
    int i;
    Interp *iPtr;

    iPtr = envPtr->iPtr;

    codeBytes = (envPtr->codeNext - envPtr->codeStart);
    objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
    exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
    auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
    cmdLocBytes = GetCmdLocEncodingSize(envPtr);
    
    /*
     * Compute the total number of bytes needed for this bytecode.
     */

    structureSize = sizeof(ByteCode);
    structureSize += TCL_ALIGN(codeBytes);        /* align object array */
    structureSize += TCL_ALIGN(objArrayBytes);    /* align exc range arr */
    structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
    structureSize += auxDataArrayBytes;
    structureSize += cmdLocBytes;

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