Compile the [throw] command.

4 files changed, 125 insertions, 7 deletions

diff --git a/ChangeLog b/ChangeLog
index 94956d9..da1ea61 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,13 @@
+2010-03-19  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompCmdsSZ.c (TclCompileThrowCmd): Added compilation for
+	the [throw] command.
+
 2010-03-18  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclListObj.c:	Prevent in overflow trouble in ListObjReplace
-	* generic/tclTestObj.c:	operations.  Thanks to kbk for fix and test.
-	* tests/listObj.test:	[Bug 2971669].
+	* generic/tclListObj.c:	[Bug 2971669]: Prevent in overflow trouble in
+	* generic/tclTestObj.c:	ListObjReplace operations. Thanks to kbk for
+	* tests/listObj.test:	fix and test.
 
 2010-03-18  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b9282ae..148baa4 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.448 2010/03/05 14:34:03 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.449 2010/03/19 11:54:06 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -238,7 +238,7 @@ static const CmdInfo builtInCmds[] = {
     {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	TclNRSubstObjCmd,	1},
     {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, 1},
     {"tailcall",	NULL,			NULL,			TclNRTailcallObjCmd,	1},
-    {"throw",		Tcl_ThrowObjCmd,	NULL,			NULL,	1},
+    {"throw",		Tcl_ThrowObjCmd,	TclCompileThrowCmd,	NULL,	1},
     {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
     {"try",		Tcl_TryObjCmd,		TclCompileTryCmd,	TclNRTryObjCmd,	1},
     {"unset",		Tcl_UnsetObjCmd,	TclCompileUnsetCmd,	NULL,	1},
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 25ff92a..f6f8efb 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.4 2010/03/18 14:35:04 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.5 2010/03/19 11:54:07 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1789,6 +1789,116 @@ PrintJumptableInfo(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileThrowCmd --
+ *
+ *	Procedure called to compile the "throw" command.
+ *
+ * Results:
+ *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ *	evaluation to runtime.
+ *
+ * Side effects:
+ *	Instructions are added to envPtr to execute the "throw" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileThrowCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    DefineLineInformation;	/* TIP #280 */
+    int numWords = parsePtr->numWords;
+    Tcl_Token *codeToken, *msgToken;
+    Tcl_Obj *objPtr;
+
+    if (numWords != 3) {
+	return TCL_ERROR;
+    }
+    codeToken = TokenAfter(parsePtr->tokenPtr);
+    msgToken = TokenAfter(codeToken);
+
+    TclNewObj(objPtr);
+    Tcl_IncrRefCount(objPtr);
+    if (TclWordKnownAtCompileTime(codeToken, objPtr)) {
+	Tcl_Obj *errPtr, *dictPtr;
+	const char *string;
+	int len;
+
+	/*
+	 * The code is known at compilation time. This allows us to issue a
+	 * very efficient sequence of instructions.
+	 */
+
+	if (Tcl_ListObjLength(interp, objPtr, &len) != TCL_OK) {
+	    /*
+	     * Must still do this; might generate an error when getting this
+	     * "ignored" value prepared as an argument.
+	     */
+
+	    CompileWord(envPtr, msgToken, interp, 2);
+	    TclCompileSyntaxError(interp, envPtr);
+	    return TCL_OK;
+	}
+	if (len == 0) {
+	    /*
+	     * Must still do this; might generate an error when getting this
+	     * "ignored" value prepared as an argument.
+	     */
+
+	    CompileWord(envPtr, msgToken, interp, 2);
+	    goto issueErrorForEmptyCode;
+	}
+	TclNewLiteralStringObj(errPtr, "-errorcode");
+	TclNewObj(dictPtr);
+	Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr);
+	Tcl_IncrRefCount(dictPtr);
+	string = Tcl_GetStringFromObj(dictPtr, &len);
+	CompileWord(envPtr, msgToken, interp, 2);
+	PushLiteral(envPtr, string, len);
+	TclDecrRefCount(dictPtr);
+	OP44(				RETURN_IMM, 1, 0);
+    } else {
+	/*
+	 * When the code token is not known at compilation time, we need to do
+	 * a little bit more work. The main tricky bit here is that the error
+	 * code has to be a list (a [throw] restriction) so we must emit extra
+	 * instructions to enforce that condition.
+	 */
+
+	CompileWord(envPtr, codeToken, interp, 1);
+	PUSH(				"-errorcode");
+	CompileWord(envPtr, msgToken, interp, 2);
+	OP4(				REVERSE, 3);
+	OP(				DUP);
+	OP(				LIST_LENGTH);
+	OP1(				JUMP_FALSE1, 16);
+	OP4(				LIST, 2);
+	OP44(				RETURN_IMM, 1, 0);
+
+	/*
+	 * Generate an error for being an empty list. Can't leverage anything
+	 * else to do this for us.
+	 */
+
+    issueErrorForEmptyCode:
+	PUSH(				"type must be non-empty list");
+	PUSH(				"");
+	OP44(				RETURN_IMM, 1, 0);
+    }
+    TclDecrRefCount(objPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileTryCmd --
  *
  *	Procedure called to compile the "try" command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4bdb3c7..9661894 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.464 2010/03/05 14:34:04 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.465 2010/03/19 11:54:07 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -3481,6 +3481,9 @@ MODULE_SCOPE int	TclCompileSubstCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileSwitchCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileThrowCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileTryCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);