From a7d5e487cdc90cf70ddff97143b7357800b9388d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 5 Feb 2010 22:39:44 +0000
Subject: Added basic compilation of [error] (the most common case only).

---
 ChangeLog             | 11 ++++++++---
 generic/tclBasic.c    |  4 ++--
 generic/tclCompCmds.c | 47 ++++++++++++++++++++++++++++++++++++++++++++++-
 generic/tclInt.h      |  5 ++++-
 4 files changed, 60 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 78963fe..045d394 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,9 +1,14 @@
+2010-02-05  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompCmds.c (TclCompileErrorCmd): Added compilation of the
+	[error] command. No new bytecodes.
+
 2010-02-05  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* tools/genStubs.tcl:	Follow-up to earlier commit today:
-	          Eliminate the need for an extra Stubs Pointer
-	          for adressing a static stub table: Just change
-	          the exported table from static to MODULE_SCOPE.
+	          Eliminate the need for an extra Stubs Pointer for adressing
+	          a static stub table: Just change the exported table from
+	          static to MODULE_SCOPE.
 	* generic/tclBasic.c
 	* generic/tclOO.c
 	* generic/tclTomMathInterface.c
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c2a8363..7eb8359 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.441 2010/02/05 20:53:12 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.442 2010/02/05 22:39:44 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -202,7 +202,7 @@ static const CmdInfo builtInCmds[] = {
     {"concat",		Tcl_ConcatObjCmd,	NULL,			NULL,	1},
     {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	1},
     {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	1},
-    {"error",		Tcl_ErrorObjCmd,	NULL,			NULL,	1},
+    {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	1},
     {"eval",		Tcl_EvalObjCmd,		NULL,			NULL,	1},
     {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	1},
     {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 5455e5d..2b59d5c 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.158 2010/01/30 16:33:25 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.159 2010/02/05 22:39:44 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1374,6 +1374,51 @@ PrintDictUpdateInfo(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileErrorCmd --
+ *
+ *	Procedure called to compile the "error" 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 "error" command at
+ *	runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileErrorCmd(
+    Tcl_Interp *interp,		/* Used for context. */
+    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. */
+{
+    /*
+     * General syntax: [error message ?errorInfo? ?errorCode?]
+     * However, we only deal with the case where there is just a message.
+     */
+    Tcl_Token *messageTokenPtr;
+    DefineLineInformation;	/* TIP #280 */
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+    messageTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    PushLiteral(envPtr, "-code error -level 0", 20);
+    CompileWord(envPtr, messageTokenPtr, interp, 1);
+    TclEmitOpcode(INST_RETURN_STK, envPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileExprCmd --
  *
  *	Procedure called to compile the "expr" command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d08ed12..0e98299 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.458 2010/02/05 10:03:23 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.459 2010/02/05 22:39:44 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -3318,6 +3318,9 @@ MODULE_SCOPE int	TclCompileDictUpdateCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileEnsemble(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileErrorCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileExprCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12