summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompCmds.c63
-rw-r--r--generic/tclCompExpr.c28
-rw-r--r--generic/tclCompile.c70
-rw-r--r--generic/tclCompile.h20
-rw-r--r--generic/tclExecute.c80
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;
}