tclcompcmds.c

来自「tcl是工具命令语言」· C语言 代码 · 共 2,168 行 · 第 1/5 页

	}
    } else {
	TclEmitOpcode(INST_LAPPEND_STK, envPtr);
    }

    done:
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLindexCmd --
 *
 *	Procedure called to compile the "lindex" command.
 *
 * Results:
 *	The return value is a standard Tcl result, which is TCL_OK if the
 *	compilation was successful.  If the command cannot be byte-compiled,
 *	TCL_OUT_LINE_COMPILE is returned.  If an error occurs then the
 *	interpreter's result contains an error message, and TCL_ERROR is
 *	returned.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lindex" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLindexCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int code, i;

    int numWords;
    numWords = parsePtr->numWords;

    /*
     * Quit if too few args
     */

    if ( numWords <= 1 ) {
	return TCL_OUT_LINE_COMPILE;
    }

    varTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);
    
    /*
     * Push the operands onto the stack.
     */
	
    for ( i = 1 ; i < numWords ; i++ ) {
	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(
		    TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);
	} else {
	    code = TclCompileTokens(interp, varTokenPtr+1,
				    varTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		return code;
	    }
	}
	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    }
	
    /*
     * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
     * if there are multiple index args.
     */

    if ( numWords == 3 ) {
	TclEmitOpcode( INST_LIST_INDEX, envPtr );
    } else {
 	TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileListCmd --
 *
 *	Procedure called to compile the "list" command.
 *
 * Results:
 *	The return value is a standard Tcl result, which is normally TCL_OK
 *	unless there was an error while parsing string. If an error occurs
 *	then the interpreter's result contains a standard error message. If
 *	complation fails because the command requires a second level of
 *	substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
 *	command should be compiled "out of line" by emitting code to
 *	invoke its command procedure (Tcl_ListObjCmd) at runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "list" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileListCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    /*
     * If we're not in a procedure, don't compile.
     */
    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

    if (parsePtr->numWords == 1) {
	/*
	 * Empty args case
	 */

	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    } else {
	/*
	 * Push the all values onto the stack.
	 */
	Tcl_Token *valueTokenPtr;
	int i, code, numWords;

	numWords = parsePtr->numWords;

	valueTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
	for (i = 1; i < numWords; i++) {
	    if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		TclEmitPush(TclRegisterNewLiteral(envPtr,
			valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	    } else {
		code = TclCompileTokens(interp, valueTokenPtr+1,
			valueTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }
	    valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
	}
	TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLlengthCmd --
 *
 *	Procedure called to compile the "llength" command.
 *
 * Results:
 *	The return value is a standard Tcl result, which is TCL_OK if the
 *	compilation was successful.  If the command cannot be byte-compiled,
 *	TCL_OUT_LINE_COMPILE is returned.  If an error occurs then the
 *	interpreter's result contains an error message, and TCL_ERROR is
 *	returned.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "llength" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLlengthCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int code;

    if (parsePtr->numWords != 2) {
	Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
		TCL_STATIC);
	return TCL_ERROR;
    }
    varTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);

    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * We could simply count the number of elements here and push
	 * that value, but that is too rare a case to waste the code space.
	 */
	TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
		varTokenPtr[1].size), envPtr);
    } else {
	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }
    TclEmitOpcode(INST_LIST_LENGTH, envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileLsetCmd --
 *
 *	Procedure called to compile the "lset" command.
 *
 * Results:
 *	The return value is a standard Tcl result, which is TCL_OK if
 *	the compilation was successful.  If the "lset" command is too
 *	complex for this function, then TCL_OUT_LINE_COMPILE is returned,
 *	indicating that the command should be compiled "out of line"
 *	(that is, not byte-compiled).  If an error occurs, TCL_ERROR is
 *	returned, and the interpreter result contains an error message.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "lset" command
 *	at runtime.
 *
 * The general template for execution of the "lset" command is:
 *	(1) Instructions to push the variable name, unless the
 *	    variable is local to the stack frame.
 *	(2) If the variable is an array element, instructions
 *	    to push the array element name.
 *	(3) Instructions to push each of zero or more "index" arguments
 *	    to the stack, followed with the "newValue" element.
 *	(4) Instructions to duplicate the variable name and/or array
 *	    element name onto the top of the stack, if either was
 *	    pushed at steps (1) and (2).
 *	(5) The appropriate INST_LOAD_* instruction to place the
 *	    original value of the list variable at top of stack.
 *	(6) At this point, the stack contains:
 *	     varName? arrayElementName? index1 index2 ... newValue oldList
 *	    The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
 *	    according as whether there is exactly one index element (LIST)
 *	    or either zero or else two or more (FLAT).  This instruction
 *	    removes everything from the stack except for the two names
 *	    and pushes the new value of the variable.
 *	(7) Finally, INST_STORE_* stores the new value in the variable
 *	    and cleans up the stack.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileLsetCmd( interp, parsePtr, envPtr )
    Tcl_Interp* interp;		/* Tcl interpreter for error reporting */
    Tcl_Parse* parsePtr;	/* Points to a parse structure for
				 * the command */
    CompileEnv* envPtr;		/* Holds the resulting instructions */
{

    int tempDepth;		/* Depth used for emitting one part
				 * of the code burst. */
    Tcl_Token* varTokenPtr;	/* Pointer to the Tcl_Token representing
				 * the parse of the variable name */

    int result;			/* Status return from library calls */

    int localIndex;		/* Index of var in local var table */
    int simpleVarName;		/* Flag == 1 if var name is simple */
    int isScalar;		/* Flag == 1 if scalar, 0 if array */

    int i;

    /* Check argument count */

    if ( parsePtr->numWords < 3 ) {
	/* Fail at run time, not in compilation */
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    result = TclPushVarName( interp, varTokenPtr, envPtr, 
            TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
    if (result != TCL_OK) {
	return result;
    }

    /* Push the "index" args and the new element value. */

    for ( i = 2; i < parsePtr->numWords; ++i ) {

	/* Advance to next arg */

	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

	/* Push an arg */

	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);
	} else {
	    result = TclCompileTokens(interp, varTokenPtr+1,
				      varTokenPtr->numComponents, envPtr);
	    if ( result != TCL_OK ) {
		return result;
	    }
	}
    }

    /*
     * Duplicate the variable name if it's been pushed.  
     */

    if ( !simpleVarName || localIndex < 0 ) {
	if ( !simpleVarName || isScalar ) {
	    tempDepth = parsePtr->numWords - 2;
	} else {
	    tempDepth = parsePtr->numWords - 1;
	}
	TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
    }

    /*
     * Duplicate an array index if one's been pushed
     */

    if ( simpleVarName && !isScalar ) {
	if ( localIndex < 0 ) {
	    tempDepth = parsePtr->numWords - 1;
	} else {
	    tempDepth = parsePtr->numWords - 2;
	}
	TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
    }

    /*
     * Emit code to load the variable's value.
     */

    if ( !simpleVarName ) {
	TclEmitOpcode( INST_LOAD_STK, envPtr );
    } else if ( isScalar ) {
	if ( localIndex < 0 ) {
	    TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
	} else if ( localIndex < 0x100 ) {
	    TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
	} else {
	    TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
	}
    } else {
	if ( localIndex < 0 ) {
	    TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
	} else if ( localIndex < 0x100 ) {
	    TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
	} else {
	    TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
	}
    }

    /*
     * Emit the correct variety of 'lset' instruction
     */

    if ( parsePtr->numWords == 4 ) {
	TclEmitOpcode( INST_LSET_LIST, envPtr );
    } else {
	TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
    }

    /*
     * Emit code to put the value back in the variable
     */

    if ( !simpleVarName ) {
	TclEmitOpcode( INST_STORE_STK, envPtr );
    } else if ( isScalar ) {
	if ( localIndex < 0 ) {
	    TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
	} else if ( localIndex < 0x100 ) {
	    TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
	} else {
	    TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
	}
    } else {
	if ( localIndex < 0 ) {
	    TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
	} else if ( localIndex < 0x100 ) {
	    TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
	} else {
	    TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
	}
    }
    
    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileRegexpCmd --
 *
 *	Procedure called to compile the "regexp" command.
 *
 * Results:
 *	The return value is a standard Tcl result, which is TCL_OK if
 *	the compilation was successful.  If the "regexp" command is too
 *	complex for this function, then TCL_OUT_LINE_COMPILE is returned,
 *	indicating that the command should be compiled "out of line"
 *	(that is, not byte-compiled).  If an error occurs, TCL_ERROR is
 *	returned, and the interpreter result contains an error message.
 *
 * Side effects: