tclcompile.c

tcl是工具命令语言

 *	contains an error message.
 *
 *	interp->termOffset is set to the offset of the character in the
 *	script just after the last one successfully processed; this will be
 *	the offset of the ']' if (flags & TCL_BRACKET_TERM).
 *
 * Side effects:
 *	Adds instructions to envPtr to evaluate the script at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileScript(interp, script, numBytes, nested, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting.
				 * Also serves as context for finding and
				 * compiling commands.  May not be NULL. */
    CONST char *script;		/* The source script to compile. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    int nested;			/* Non-zero means this is a nested command:
				 * close bracket ']' should be considered a
				 * command terminator. If zero, close
				 * bracket has no special meaning. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Parse parse;
    int lastTopLevelCmdIndex = -1;
    				/* Index of most recent toplevel command in
 				 * the command location table. Initialized
				 * to avoid compiler warning. */
    int startCodeOffset = -1;	/* Offset of first byte of current command's
                                 * code. Init. to avoid compiler warning. */
    unsigned char *entryCodeNext = envPtr->codeNext;
    CONST char *p, *next;
    Namespace *cmdNsPtr;
    Command *cmdPtr;
    Tcl_Token *tokenPtr;
    int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
    int commandLength, objIndex, code;
    Tcl_DString ds;

    Tcl_DStringInit(&ds);

    if (numBytes < 0) {
	numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);
    isFirstCmd = 1;

    /*
     * Each iteration through the following loop compiles the next
     * command from the script.
     */

    p = script;
    bytesLeft = numBytes;
    gotParse = 0;
    do {
	if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
	    code = TCL_ERROR;
	    goto error;
	}
	gotParse = 1;
	if (nested) {
	    /*
	     * This is an unusual situation where the caller has passed us
	     * a non-zero value for "nested".  How unusual?  Well, this
	     * procedure, TclCompileScript, is internal to Tcl, so all
	     * callers should be within Tcl itself.  All but one of those
	     * callers explicitly pass in (nested = 0).  The exceptional
	     * caller is TclSetByteCodeFromAny, which will pass in
	     * (nested = 1) if and only if the flag TCL_BRACKET_TERM
	     * is set in the evalFlags field of interp.
	     *
	     * It appears that the TCL_BRACKET_TERM flag is only ever set
	     * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx
	     * which clears the flag before passing the interp along.
	     * So, I don't think this procedure, TclCompileScript, is
	     * **ever** called with (nested != 0). 
	     * (The testsuite indeed doesn't exercise this code. MS)
	     *
	     * This means that the branches in this procedure that are
	     * only active when (nested != 0) are probably never exercised.
	     * This means that any bugs in them go unnoticed, and any bug
	     * fixes in them have a semi-theoretical nature.
	     *
	     * All that said, the spec for this procedure says it should
	     * handle the (nested != 0) case, so here's an attempt to fix
	     * bugs (Tcl Bug 681841) in that case.  Just in case some
	     * callers eventually come along and expect it to work...
	     */

	    if (parse.term == (script + numBytes)) {
		/* 
		 * The (nested != 0) case is meant to indicate that the
		 * caller found an open bracket ([) and asked us to
		 * parse and compile Tcl commands up to the matching
		 * close bracket (]).  We have to detect and handle
		 * the case where the close bracket is missing.
		 */

		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("missing close-bracket", -1));
		code = TCL_ERROR;
		goto error;
	    }
	}
	if (parse.numWords > 0) {
	    /*
	     * If not the first command, pop the previous command's result
	     * and, if we're compiling a top level command, update the last
	     * command's code size to account for the pop instruction.
	     */

	    if (!isFirstCmd) {
		TclEmitOpcode(INST_POP, envPtr);
		if (!nested) {
		    envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
			   (envPtr->codeNext - envPtr->codeStart)
			   - startCodeOffset;
		}
	    }

	    /*
	     * Determine the actual length of the command.
	     */

	    commandLength = parse.commandSize;
	    if (parse.term == parse.commandStart + commandLength - 1) {
		/*
		 * The command terminator character (such as ; or ]) is
		 * the last character in the parsed command.  Reduce the
		 * length by one so that the trace message doesn't include
		 * the terminator character.
		 */
		
		commandLength -= 1;
	    }

#ifdef TCL_COMPILE_DEBUG
	    /*
             * If tracing, print a line for each top level command compiled.
             */

	    if ((tclTraceCompile >= 1)
		    && !nested && (envPtr->procPtr == NULL)) {
		fprintf(stdout, "  Compiling: ");
		TclPrintSource(stdout, parse.commandStart,
			TclMin(commandLength, 55));
		fprintf(stdout, "\n");
	    }
#endif
	    /*
	     * Each iteration of the following loop compiles one word
	     * from the command.
	     */
	    
	    envPtr->numCommands++;
	    currCmdIndex = (envPtr->numCommands - 1);
	    if (!nested) {
		lastTopLevelCmdIndex = currCmdIndex;
	    }
	    startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
	    EnterCmdStartData(envPtr, currCmdIndex,
	            (parse.commandStart - envPtr->source), startCodeOffset);
	    
	    for (wordIdx = 0, tokenPtr = parse.tokenPtr;
		    wordIdx < parse.numWords;
		    wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
		if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    /*
		     * If this is the first word and the command has a
		     * compile procedure, let it compile the command.
		     */

		    if (wordIdx == 0) {
			if (envPtr->procPtr != NULL) {
			    cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
			} else {
			    cmdNsPtr = NULL; /* use current NS */
			}

			/*
			 * We copy the string before trying to find the command
			 * by name.  We used to modify the string in place, but
			 * this is not safe because the name resolution
			 * handlers could have side effects that rely on the
			 * unmodified string.
			 */

			Tcl_DStringSetLength(&ds, 0);
			Tcl_DStringAppend(&ds, tokenPtr[1].start,
				tokenPtr[1].size);

			cmdPtr = (Command *) Tcl_FindCommand(interp,
				Tcl_DStringValue(&ds),
			        (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);

			if ((cmdPtr != NULL)
			        && (cmdPtr->compileProc != NULL)
			        && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
			        && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
			    code = (*(cmdPtr->compileProc))(interp, &parse,
			            envPtr);
			    if (code == TCL_OK) {
				goto finishCommand;
			    } else if (code == TCL_OUT_LINE_COMPILE) {
				/* do nothing */
			    } else { /* an error */
				/*
				 * There was a compilation error, the last
				 * command did not get compiled into (*envPtr).
				 * Decrement the number of commands
				 * claimed to be in (*envPtr).
				 */
				envPtr->numCommands--;
				goto log;
			    }
			}

			/*
			 * No compile procedure so push the word. If the
			 * command was found, push a CmdName object to
			 * reduce runtime lookups.
			 */

			objIndex = TclRegisterNewLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size);
			if (cmdPtr != NULL) {
			    TclSetCmdNameObj(interp,
			           envPtr->literalArrayPtr[objIndex].objPtr,
				   cmdPtr);
			}
		    } else {
			objIndex = TclRegisterNewLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size);
		    }
		    TclEmitPush(objIndex, envPtr);
		} else {
		    /*
		     * The word is not a simple string of characters.
		     */
		    
		    code = TclCompileTokens(interp, tokenPtr+1,
			    tokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			goto log;
		    }
		}
	    }

	    /*
	     * Emit an invoke instruction for the command. We skip this
	     * if a compile procedure was found for the command.
	     */
	    
	    if (wordIdx > 0) {
		if (wordIdx <= 255) {
		    TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
		} else {
		    TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
		}
	    }

	    /*
	     * Update the compilation environment structure and record the
	     * offsets of the source and code for the command.
	     */

	    finishCommand:
	    EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
		    (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
	    isFirstCmd = 0;
	} /* end if parse.numWords > 0 */

	/*
	 * Advance to the next command in the script.
	 */
	
	next = parse.commandStart + parse.commandSize;
	bytesLeft -= (next - p);
	p = next;
	Tcl_FreeParse(&parse);
	gotParse = 0;
	if (nested && (*parse.term == ']')) {
	    /*
	     * We get here in the special case where TCL_BRACKET_TERM was
	     * set in the interpreter and the latest parsed command was
	     * terminated by the matching close-bracket we were looking for.
	     * Stop compilation.
	     */
	    
	    break;
	}
    } while (bytesLeft > 0);

    /*
     * If the source script yielded no instructions (e.g., if it was empty),
     * push an empty string as the command's result.
     */
    
    if (envPtr->codeNext == entryCodeNext) {
	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
	        envPtr);
    }
    
    if (nested) {
	/*
	 * When (nested != 0) back up 1 character to have 
	 * iPtr->termOffset indicate the offset to the matching
	 * close-bracket.
	 */

	iPtr->termOffset = (p - 1) - script;
    } else {
	iPtr->termOffset = (p - script);
    }
    Tcl_DStringFree(&ds);
    return TCL_OK;
	
    error:
    /*
     * Generate various pieces of error information, such as the line
     * number where the error occurred and information to add to the
     * errorInfo variable. Then free resources that had been allocated
     * to the command.
     */

    commandLength = parse.commandSize;
    if (parse.term == parse.commandStart + commandLength - 1) {
	/*
	 * The terminator character (such as ; or ]) of the command where
	 * the error occurred is the last character in the parsed command.
	 * Reduce the length by one so that the error message doesn't
	 * include the terminator character.
	 */

	commandLength -= 1;
    }

    log:
    LogCompilationInfo(interp, script, parse.commandStart, commandLength);
    if (gotParse) {
	Tcl_FreeParse(&parse);
    }
    iPtr->termOffset = (p - script);
    Tcl_DStringFree(&ds);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileTokens --
 *
 *	Given an array of tokens parsed from a Tcl command (e.g., the tokens
 *	that make up a word) this procedure emits instructions to evaluate
 *	the tokens and concatenate their values to form a single result
 *	value on the interpreter's runtime evaluation stack.
 *
 * 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 push and evaluate the tokens
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileTokens(interp, tokenPtr, count, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    Tcl_Token *tokenPtr;	/* Pointer to first in an array of tokens
				 * to compile. */
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
    char buffer[TCL_UTF_MAX];
    CONST char *name, *p;
    int numObjsToConcat, nameBytes, localVarName, localVar;
    int length, i, code;
    unsigned char *entryCodeNext = envPtr->codeNext;

    Tcl_DStringInit(&textBuffer);
    numObjsToConcat = 0;