* generic/tclCompExpr.c: Call TclCompileSyntaxError() when

        expression syntax errors are found when compiling expressions.  With
        this in place, convert TclCompileExpr to return void, since there's no
        longer any need to report TCL_ERROR.
        * generic/tclCompile.c: Update callers.
        * generic/tclExecute.c:

        * generic/tclCompCmds.c:        New routine TclCompileSyntaxError()
        * generic/tclCompile.h: to directly compile bytecodes that report a
        * generic/tclCompile.c: syntax error, rather than (ab)use a call to
        TclCompileReturnCmd.  Also, undo the most recent commit that papered
        over some issues with that (ab)use.  New routine produces a new
        opcode INST_SYNTAX, which is a minor variation of INST_RETURN_IMM.
        Also a bit of constification.

6 files changed, 87 insertions, 189 deletions

diff --git a/ChangeLog b/ChangeLog
index 25cbc3c..e4109ca 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,20 @@
 2007-08-27  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclCompExpr.c:	Call TclCompileSyntaxError() when
+	expression syntax errors are found when compiling expressions.  With
+	this in place, convert TclCompileExpr to return void, since there's no
+	longer any need to report TCL_ERROR.
+	* generic/tclCompile.c:	Update callers.
+	* generic/tclExecute.c:
+
+	* generic/tclCompCmds.c:	New routine TclCompileSyntaxError()
+	* generic/tclCompile.h:	to directly compile bytecodes that report a
+	* generic/tclCompile.c:	syntax error, rather than (ab)use a call to
+	TclCompileReturnCmd.  Also, undo the most recent commit that papered
+	over some issues with that (ab)use.  New routine produces a new
+	opcode INST_SYNTAX, which is a minor variation of INST_RETURN_IMM.
+	Also a bit of constification.
+
 	* generic/tclCompile.c:	Move the deallocation of local LiteralTable
 	* generic/tclCompExpr.c:	entries into TclFreeCompileEnv().
 	* generic/tclExecute.c:	Update callers.
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;
 	}