diff options
Diffstat (limited to 'generic/tclCompile.c')
| -rw-r--r-- | generic/tclCompile.c | 264 |
1 files changed, 80 insertions, 184 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f02b29d..7b79e66 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.74 2004/09/23 00:34:31 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.75 2004/09/26 16:36:04 msofer Exp $ */ #include "tclInt.h" @@ -317,9 +317,6 @@ static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); -static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *script, CONST char *command, - int length)); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats _ANSI_ARGS_(( ByteCode *codePtr)); @@ -383,7 +380,7 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; - int length, result; + int length, result = TCL_OK; char *string; #ifdef TCL_COMPILE_DEBUG @@ -398,43 +395,41 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) string = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length); - result = TclCompileScript(interp, string, length, &compEnv); + TclCompileScript(interp, string, length, &compEnv); - if (result == TCL_OK) { - /* - * Successful compilation. Add a "done" instruction at the end. - */ + /* + * Successful compilation. Add a "done" instruction at the end. + */ - TclEmitOpcode(INST_DONE, &compEnv); + TclEmitOpcode(INST_DONE, &compEnv); - /* - * Invoke the compilation hook procedure if one exists. - */ + /* + * Invoke the compilation hook procedure if one exists. + */ - if (hookProc) { - result = (*hookProc)(interp, &compEnv, clientData); - } + if (hookProc) { + result = (*hookProc)(interp, &compEnv, clientData); + } - /* - * Change the object into a ByteCode object. Ownership of the literal - * objects and aux data items is given to the ByteCode object. - */ + /* + * Change the object into a ByteCode object. Ownership of the literal + * objects and aux data items is given to the ByteCode object. + */ #ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); + TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - } -#endif /* TCL_COMPILE_DEBUG */ + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); } +#endif /* TCL_COMPILE_DEBUG */ if (result != TCL_OK) { /* - * Compilation errors. + * Handle any error from the hookProc */ entryPtr = compEnv.literalArrayPtr; @@ -896,7 +891,7 @@ TclWordKnownAtCompileTime(tokenPtr, valuePtr) *---------------------------------------------------------------------- */ -int +void TclCompileScript(interp, script, numBytes, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. * Also serves as context for finding and @@ -987,7 +982,7 @@ TclCompileScript(interp, script, numBytes, envPtr) TclCompileReturnCmd(interp, &subParse, envPtr); Tcl_DecrRefCount(returnCmd); Tcl_FreeParse(&subParse); - return TCL_OK; + return; } gotParse = 1; if (parse.numWords > 0) { @@ -1002,7 +997,8 @@ TclCompileScript(interp, script, numBytes, envPtr) if (!isFirstCmd) { TclEmitOpcode(INST_POP, envPtr); envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - startCodeOffset; + (envPtr->codeNext - envPtr->codeStart) + - startCodeOffset; } /* @@ -1118,30 +1114,27 @@ TclCompileScript(interp, script, numBytes, envPtr) /* * Fix the bytecode length. */ - unsigned char *fixPtr = envPtr->codeStart + savedCodeNext + 1; - unsigned int fixLen = envPtr->codeNext - envPtr->codeStart - - savedCodeNext; + unsigned char *fixPtr = envPtr->codeStart + + savedCodeNext + 1; + unsigned int fixLen = envPtr->codeNext + - envPtr->codeStart + - savedCodeNext; TclStoreInt4AtPtr(fixLen, fixPtr); } goto finishCommand; } else if (code == TCL_OUT_LINE_COMPILE) { /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before - * TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055] + * Restore numCommands and codeNext to their + * correct values, removing any commands + * compiled before TCL_OUT_LINE_COMPILE + * [Bugs 705406 and 735055] */ envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; + envPtr->codeNext = envPtr->codeStart + + savedCodeNext; } 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; + Tcl_Panic("TclCompileScript: compileProc returned TCL_ERROR\n"); } } @@ -1177,11 +1170,8 @@ TclCompileScript(interp, script, numBytes, envPtr) * The word is not a simple string of characters. */ - code = TclCompileTokens(interp, tokenPtr+1, + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto log; - } } if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { TclEmitInstInt4(INST_EXPAND_STKTOP, @@ -1260,16 +1250,6 @@ TclCompileScript(interp, script, numBytes, envPtr) envPtr->numSrcBytes = (p - script); Tcl_DStringFree(&ds); - return TCL_OK; - - log: - LogCompilationInfo(interp, script, parse.commandStart, commandLength); - if (gotParse) { - Tcl_FreeParse(&parse); - } - envPtr->numSrcBytes = (p - script); - Tcl_DStringFree(&ds); - return code; } /* @@ -1293,7 +1273,7 @@ TclCompileScript(interp, script, numBytes, envPtr) *---------------------------------------------------------------------- */ -int +void 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 @@ -1307,7 +1287,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) char buffer[TCL_UTF_MAX]; CONST char *name, *p; int numObjsToConcat, nameBytes, localVarName, localVar; - int length, i, code; + int length, i; unsigned char *entryCodeNext = envPtr->codeNext; Tcl_DStringInit(&textBuffer); @@ -1341,11 +1321,8 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_DStringFree(&textBuffer); } - code = TclCompileScript(interp, tokenPtr->start+1, + TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); - if (code != TCL_OK) { - goto error; - } numObjsToConcat++; break; @@ -1422,16 +1399,8 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) envPtr); } } else { - code = TclCompileTokens(interp, tokenPtr+2, + 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) { @@ -1486,11 +1455,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) envPtr); } Tcl_DStringFree(&textBuffer); - return TCL_OK; - - error: - Tcl_DStringFree(&textBuffer); - return code; } /* @@ -1514,7 +1478,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) *---------------------------------------------------------------------- */ -int +void 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 @@ -1523,30 +1487,23 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) * 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, 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. - */ + /* + * Handle the common case: if there is a single text token, + * compile it into an inline sequence of instructions. + */ + + TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); + } else { + /* + * 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; + TclCompileTokens(interp, tokenPtr, count, envPtr); + TclEmitOpcode(INST_EVAL_STK, envPtr); } - TclEmitOpcode(INST_EVAL_STK, envPtr); - return TCL_OK; } /* @@ -1570,7 +1527,7 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) *---------------------------------------------------------------------- */ -int +void 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 @@ -1582,10 +1539,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; - int numBytes, i, code; - CONST char *script; - - code = TCL_OK; + int i, concatItems; /* * If the expression is a single word that doesn't require @@ -1593,10 +1547,16 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - script = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - code = TclCompileExpr(interp, script, numBytes, envPtr); - return code; + CONST char *script = tokenPtr[1].start; + int numBytes = tokenPtr[1].size; + int savedNumCmds = envPtr->numCommands; + unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart; + + if (TclCompileExpr(interp, script, numBytes, envPtr) == TCL_OK) { + return; + } + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + savedCodeNext; } /* @@ -1606,30 +1566,22 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, - envPtr); - if (code != TCL_OK) { - break; - } + TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); 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); + concatItems = 2*numWords - 1; + while (concatItems > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + concatItems -= 254; } - - return code; + if (concatItems > 1) { + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + } + TclEmitOpcode(INST_EXPR_STK, envPtr); } /* @@ -1791,62 +1743,6 @@ TclInitByteCodeObj(objPtr, envPtr) /* *---------------------------------------------------------------------- * - * LogCompilationInfo -- - * - * This procedure is invoked after an error occurs during compilation. - * It adds information to the "errorInfo" variable to describe the - * command that was being compiled when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Information about the command is added to errorInfo and the - * line number stored internally in the interpreter is set. If this - * is the first call to this procedure or Tcl_AddObjErrorInfo since - * an error occurred, then old information in errorInfo is - * deleted. - * - *---------------------------------------------------------------------- - */ - -static void -LogCompilationInfo(interp, script, command, length) - Tcl_Interp *interp; /* Interpreter in which to log the - * information. */ - CONST char *script; /* First character in script containing - * command (must be <= command). */ - CONST char *command; /* First character in command that - * generated the error. */ - int length; /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ -{ - register CONST char *p; - Interp *iPtr = (Interp *) interp; - Tcl_Obj *message; - - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - message = Tcl_NewStringObj("\n while compiling\n\"", -1); - Tcl_IncrRefCount(message); - TclAppendLimitedToObj(message, command, length, 153, NULL); - Tcl_AppendToObj(message, "\"", -1); - TclAppendObjToErrorInfo(interp, message); - Tcl_DecrRefCount(message); -} - -/* - *---------------------------------------------------------------------- - * * TclFindCompiledLocal -- * * This procedure is called at compile time to look up and optionally |