summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-03-19 11:54:06 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-03-19 11:54:06 (GMT)
commit9d6f5201163bb582aa7e121e4c8b9799ec415479 (patch)
tree9ae9c5f44af5aa9421bb2bd4ddb91f67e9ab4829 /generic
parent5047cca473a0226f06a3b69d9f0b62a0b3732e79 (diff)
downloadtcl-9d6f5201163bb582aa7e121e4c8b9799ec415479.zip
tcl-9d6f5201163bb582aa7e121e4c8b9799ec415479.tar.gz
tcl-9d6f5201163bb582aa7e121e4c8b9799ec415479.tar.bz2
Compile the [throw] command.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCompCmdsSZ.c112
-rw-r--r--generic/tclInt.h5
3 files changed, 117 insertions, 4 deletions
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);