diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclCompCmds.c | 63 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 28 | ||||
| -rw-r--r-- | generic/tclCompile.c | 70 | ||||
| -rw-r--r-- | generic/tclCompile.h | 20 | ||||
| -rw-r--r-- | generic/tclExecute.c | 80 |
5 files changed, 72 insertions, 189 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f920c87..1991ffb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.115 2007/08/23 19:35:54 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.116 2007/08/27 19:56:51 dgp Exp $ */ #include "tclInt.h" @@ -24,9 +24,6 @@ * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp, int word); - * - * NOTE: Take care to keep this macro definition in sync with the - * expansion found in TclCompileReturnCmd(). */ #define CompileWord(envPtr, tokenPtr, interp, word) \ @@ -166,6 +163,9 @@ static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp, static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); +static void CompileReturnInternal(CompileEnv *envPtr, + unsigned char op, int code, int level, + Tcl_Obj *returnOpts); /* * Flags bits used by PushVarName. @@ -3140,31 +3140,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - - /* - * This used to be the macro call - * - * CompileWord(envPtr, wordTokenPtr, interp, numWords-1); - * - * That has been replaced with the following expansion so that - * we can handle the case (eclIndex < 0), which happens when - * callers other than the central TclCompileScript compiler - * engine call this routine. Those other callers do not take - * care to initialize things in envPtr to the liking of the - * TIP 280 handling code in the unmodified CompileWord macro, - * so crash protection is needed here. - */ - - if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterNewLiteral(envPtr, wordTokenPtr[1].start, - wordTokenPtr[1].size), envPtr); - } else { - if (eclIndex >= 0) { - envPtr->line = mapPtr->loc[eclIndex].line[numWords-1]; - } - TclCompileTokens(interp, wordTokenPtr+1, - wordTokenPtr->numComponents, envPtr); - } + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); } else { /* * No explict result argument, so default result is empty string. @@ -3213,10 +3189,35 @@ TclCompileReturnCmd( * emit the INST_RETURN_IMM instruction with code and level as operands. */ + CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); + return TCL_OK; +} + +static void +CompileReturnInternal( + CompileEnv *envPtr, + unsigned char op, + int code, + int level, + Tcl_Obj *returnOpts) +{ TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(INST_RETURN_IMM, code, envPtr); + TclEmitInstInt4(op, code, envPtr); TclEmitInt4(level, envPtr); - return TCL_OK; +} + +void +TclCompileSyntaxError( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + Tcl_Obj *msg = Tcl_GetObjResult(interp); + int numBytes; + const char *bytes = Tcl_GetStringFromObj(msg, &numBytes); + + TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, + Tcl_GetReturnOptions(interp, TCL_ERROR)); } /* diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0d8a72e..cc31754 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.82 2007/08/27 15:12:38 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.83 2007/08/27 19:56:51 dgp Exp $ */ #include "tclInt.h" @@ -2014,9 +2014,7 @@ ParseLexeme( *---------------------------------------------------------------------- */ -/* TODO: Convert this to return void. Generate error throwing bytecode - * for syntax errors instead of failing to compile. */ -int +void TclCompileExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *script, /* The source script to compile. */ @@ -2048,6 +2046,8 @@ TclCompileExpr( Tcl_ListObjGetElements(NULL, funcList, &objc, &funcObjv); CompileExprTree(interp, opTree, 0, &litObjv, funcObjv, parsePtr->tokenPtr, envPtr, 1 /* optimize */); + } else { + TclCompileSyntaxError(interp, envPtr); } Tcl_FreeParse(parsePtr); @@ -2055,7 +2055,6 @@ TclCompileExpr( Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree((char *) opTree); - return code; } /* @@ -2350,24 +2349,7 @@ CompileExprTree( TclEmitPush(TclAddLiteralObj(envPtr, Tcl_GetObjResult(interp), NULL), envPtr); } else { - char *cmd; - int length; - Tcl_Obj *returnCmd; - Tcl_Parse *parsePtr = (Tcl_Parse *) - TclStackAlloc(interp, sizeof(Tcl_Parse)); - - TclNewLiteralStringObj(returnCmd, "return "); - Tcl_IncrRefCount(returnCmd); - Tcl_AppendObjToObj(returnCmd, - Tcl_GetReturnOptions(interp, TCL_ERROR)); - Tcl_ListObjAppendElement(NULL, returnCmd, - Tcl_GetObjResult(interp)); - cmd = Tcl_GetStringFromObj(returnCmd, &length); - Tcl_ParseCommand(interp, cmd, length, 0, parsePtr); - TclCompileReturnCmd(interp, parsePtr, envPtr); - Tcl_DecrRefCount(returnCmd); - Tcl_FreeParse(parsePtr); - TclStackFree(interp, parsePtr); + TclCompileSyntaxError(interp, envPtr); } Tcl_RestoreInterpState(interp, save); convert = 0; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ab7d2ce..c3ff82a 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.127 2007/08/27 15:12:38 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.128 2007/08/27 19:56:51 dgp Exp $ */ #include "tclInt.h" @@ -381,9 +381,8 @@ InstructionDesc tclInstructionTable[] = { {"variable", 5, 0, 1, {OPERAND_LVT4}}, /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ - {"noop", 1, 0, 0, {OPERAND_NONE}}, - /* finds namespace and otherName in stack, links to local variable at - * index op1. Leaves the namespace on stack. */ + {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, + /* Compiled bytecodes to signal syntax error. */ {0} }; @@ -467,7 +466,7 @@ TclSetByteCodeFromAny( LiteralEntry *entryPtr; register int i; int length, result = TCL_OK; - char *stringPtr; + const char *stringPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { @@ -830,7 +829,7 @@ TclInitCompileEnv( * structure is initialized. */ register CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ - char *stringPtr, /* The source string to be compiled. */ + const char *stringPtr, /* The source string to be compiled. */ int numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ int word) /* Index of the word in that context getting @@ -1158,52 +1157,14 @@ TclCompileScript( cmdLine = envPtr->line; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { - /* - * Compile bytecodes to report the parse error at runtime. - */ - Tcl_Obj *returnCmd; - Tcl_Obj *errMsg = Tcl_GetObjResult(interp); - Tcl_Obj *errInfo = Tcl_DuplicateObj(errMsg); - char *cmdString; - int cmdLength; - Tcl_Parse *subParsePtr = - (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); - int errorLine = 1; - - TclNewLiteralStringObj(returnCmd, - "return -code 1 -level 0 -errorinfo"); - Tcl_IncrRefCount(returnCmd); - Tcl_IncrRefCount(errInfo); - Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1); - Tcl_AppendLimitedToObj(errInfo, parsePtr->commandStart, + /* Compile bytecodes to report the parse error at runtime. */ + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, /* Drop the command terminator (";","]") if appropriate */ (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1)? - parsePtr->commandSize - 1 : parsePtr->commandSize, 153, NULL); - Tcl_AppendToObj(errInfo, "\"", -1); - - Tcl_ListObjAppendElement(NULL, returnCmd, errInfo); - - for (p = envPtr->source; p != parsePtr->commandStart; p++) { - if (*p == '\n') { - errorLine++; - } - } - Tcl_ListObjAppendElement(NULL, returnCmd, - Tcl_NewStringObj("-errorline", -1)); - Tcl_ListObjAppendElement(NULL, returnCmd, - Tcl_NewIntObj(errorLine)); - - Tcl_ListObjAppendElement(NULL, returnCmd, errMsg); - Tcl_DecrRefCount(errInfo); - - cmdString = Tcl_GetStringFromObj(returnCmd, &cmdLength); - Tcl_ParseCommand(interp, cmdString, cmdLength, 0, subParsePtr); - TclCompileReturnCmd(interp, subParsePtr, envPtr); - Tcl_DecrRefCount(returnCmd); - Tcl_FreeParse(subParsePtr); - TclStackFree(interp, subParsePtr); + parsePtr->commandSize - 1 : parsePtr->commandSize); + TclCompileSyntaxError(interp, envPtr); break; } gotParse = 1; @@ -1823,17 +1784,8 @@ TclCompileExprWords( */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - 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; - } - Tcl_ResetResult(interp); - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; + TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr); + return; } /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index bdc190e..0dc8eef 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -8,7 +8,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.h,v 1.75 2007/07/31 17:03:37 msofer Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.76 2007/08/27 19:56:51 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -215,7 +215,7 @@ typedef struct CompileEnv { * compiled. Commands and their compile procs * are specific to an interpreter so the code * emitted will depend on the interpreter. */ - char *source; /* The source string being compiled by + const char *source; /* The source string being compiled by * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ @@ -346,7 +346,7 @@ typedef struct ByteCode { unsigned int flags; /* flags describing state for the codebyte. * this variable holds ORed values from the * TCL_BYTECODE_ masks defined above */ - char *source; /* The source string from which this ByteCode + const char *source; /* The source string from which this ByteCode * was compiled. Note that this pointer is not * owned by the ByteCode and must not be freed * or modified by it. */ @@ -626,8 +626,12 @@ typedef struct ByteCode { #define INST_NSUPVAR 123 #define INST_VARIABLE 124 +/* Instruction to support compiling syntax error to bytecode */ + +#define INST_SYNTAX 125 + /* The last opcode */ -#define LAST_INST_OPCODE 124 +#define LAST_INST_OPCODE 125 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -834,7 +838,7 @@ MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); -MODULE_SCOPE int TclCompileExpr(Tcl_Interp *interp, CONST char *script, +MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, CONST char *script, int numBytes, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, @@ -842,6 +846,8 @@ MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, CONST char *script, int numBytes, CompileEnv *envPtr); +MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, + CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); @@ -879,8 +885,8 @@ MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompilation(void); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, - CompileEnv *envPtr, char *string, int numBytes, - CONST CmdFrame* invoker, int word); + CompileEnv *envPtr, const char *string, + int numBytes, CONST CmdFrame* invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); #ifdef TCL_COMPILE_STATS diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3156450..2647723 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.325 2007/08/27 15:12:38 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.326 2007/08/27 19:56:51 dgp Exp $ */ #include "tclInt.h" @@ -1114,42 +1114,8 @@ Tcl_ExprObj( register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ - AuxData *auxDataPtr; - LiteralEntry *entryPtr; - Tcl_Obj *saveObjPtr, *resultPtr; - char *string; - int length, i, result; - - /* - * First handle some common expressions specially. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - if (length == 1) { - if (*string == '0') { - TclNewBooleanObj(resultPtr, 0); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } else if (*string == '1') { - TclNewBooleanObj(resultPtr, 1); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } - } else if ((length == 2) && (*string == '!')) { - if (*(string+1) == '0') { - TclNewBooleanObj(resultPtr, 1); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } else if (*(string+1) == '1') { - TclNewBooleanObj(resultPtr, 0); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } - } + Tcl_Obj *saveObjPtr; + int result; /* * Get the ByteCode from the object. If it exists, make sure it hasn't @@ -1178,40 +1144,12 @@ Tcl_ExprObj( } } if (objPtr->typePtr != &tclByteCodeType) { - /* - * TIP #280: No invoker (yet) - Expression compilation. - */ + /* TIP #280: No invoker (yet) - Expression compilation. */ + int length; + const char *string = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); - result = TclCompileExpr(interp, string, length, &compEnv); - - if (result != TCL_OK) { - /* - * Compilation errors. Free storage allocated for compilation. - */ - -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); -#endif /*TCL_COMPILE_DEBUG*/ - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - TclFreeCompileEnv(&compEnv); - return result; - } + TclCompileExpr(interp, string, length, &compEnv); /* * Successful compilation. If the expression yielded no instructions, @@ -1799,6 +1737,7 @@ TclExecuteByteCode( } switch (*pc) { + case INST_SYNTAX: case INST_RETURN_IMM: { int code = TclGetInt4AtPtr(pc+1); int level = TclGetUInt4AtPtr(pc+5); @@ -1815,6 +1754,9 @@ TclExecuteByteCode( NEXT_INST_F(9, 1, 0); } else { Tcl_SetObjResult(interp, OBJ_UNDER_TOS); + if (*pc == INST_SYNTAX) { + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } cleanup = 2; goto processExceptionReturn; } |