Move [throw] implementation into C.

6 files changed, 144 insertions, 35 deletions

diff --git a/ChangeLog b/ChangeLog
index c7fc057..8f7ab29 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,21 +1,26 @@
+2009-01-13  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCmdMZ.c (Tcl_ThrowObjCmd):	Move implementation of [throw]
+	* library/init.tcl (throw):		to C from Tcl.
+
 2009-01-12  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclBasic.c (Tcl_DeleteCommandFromToken): One consequence
-	of the NRE rewrite is that there are now situations where a NULL
-	objProc field in a Command struct is perfectly normal.  Removed an
-	outdated comment in Tcl_DeleteCommandFromToken that claimed we 
-	use (cmdPtr->objPtr == NULL) as a test of command validity.  In fact
-	we use (cmdPtr->flags & CMD_IS_DELETED) to perform that test.
-	Also removed the setting to NULL, since any extension following the
-	advice of the old comment is going to be broken by NRE anyway, and
-	needs to shift to flag-based testing (or stop intruding into
-	such internal matters).  Part of [Bug 2486550].
+	* generic/tclBasic.c (Tcl_DeleteCommandFromToken): One consequence of
+	the NRE rewrite is that there are now situations where a NULL objProc
+	field in a Command struct is perfectly normal.  Removed an outdated
+	comment in Tcl_DeleteCommandFromToken that claimed we use
+	cmdPtr->objPtr==NULL as a test of command validity. In fact we use
+	cmdPtr->flags&CMD_IS_DELETED to perform that test. Also removed the
+	setting to NULL, since any extension following the advice of the old
+	comment is going to be broken by NRE anyway, and needs to shift to
+	flag-based testing (or stop intruding into such internal matters).
+	Part of [Bug 2486550].
 
 2009-01-09  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclStringObj.c (STRING_SIZE): Corrected failure to limit
-	memory allocation requests to the sizes that can be supported by
-	Tcl's memory allocation routines.  [Bug 2494093].
+	memory allocation requests to the sizes that can be supported by Tcl's
+	memory allocation routines. [Bug 2494093]
 
 2009-01-09  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -26,7 +31,7 @@
 
 	* generic/tclStringObj.c (STRING_UALLOC):  Added missing parens
 	required to get correct results out of things like
-	STRING_UALLOC(num + append).  [Bug 2494093].
+	STRING_UALLOC(num + append). [Bug 2494093]
 
 2009-01-08  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d39f73f..3eab76a 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.381 2009/01/12 16:50:03 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.382 2009/01/13 20:30:03 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -208,6 +208,7 @@ static const CmdInfo builtInCmds[] = {
     {"split",		Tcl_SplitObjCmd,	NULL,			NULL,	1},
     {"subst",		Tcl_SubstObjCmd,	NULL,			NULL,	1},
     {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	NULL,	1},
+    {"throw",		Tcl_ThrowObjCmd,	NULL,			NULL,	1},
     {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
     {"unset",		Tcl_UnsetObjCmd,	NULL,			NULL,	1},
     {"uplevel",		Tcl_UplevelObjCmd,	NULL,			TclNRUplevelObjCmd,	1},
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index f5f6547..7cb14b5 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -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: tclCmdMZ.c,v 1.175 2009/01/09 11:21:45 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.176 2009/01/13 20:30:03 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -3911,6 +3911,66 @@ Tcl_SwitchObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * Tcl_ThrowObjCmd --
+ *
+ *	This procedure is invoked to process the "throw" Tcl command. See the
+ *	user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_ThrowObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    Tcl_Obj *options;
+    int len;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "type message");
+	return TCL_ERROR;
+    }
+
+    /*
+     * The type must be a list of at least length 1.
+     */
+
+    if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+	return TCL_ERROR;
+    } else if (len < 1) {
+	Tcl_AppendResult(interp, "type must be non-empty list", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Now prepare the result options dictionary. We use the list API as it is
+     * slightly more convenient.
+     */
+
+    TclNewLiteralStringObj(options, "-code error -level 0 -errorcode");
+    Tcl_ListObjAppendElement(NULL, options, objv[1]);
+
+    /*
+     * We're ready to go. Fire things into the low-level result machinery.
+     */
+
+    Tcl_SetObjResult(interp, objv[2]);
+    return Tcl_SetReturnOptions(interp, options);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_TimeObjCmd --
  *
  *	This object-based procedure is invoked to process the "time" Tcl
@@ -4000,6 +4060,45 @@ Tcl_TimeObjCmd(
     return TCL_OK;
 }
 
+#if 0 /* not yet implemented */
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_TryObjCmd --
+ *
+ *	This procedure is invoked to process the "try" Tcl command. See the
+ *	user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_TryObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv);    
+}
+
+int
+TclNRTryObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    
+}
+#endif /* not yet implemented */
+
 /*
  *----------------------------------------------------------------------
  *
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 67ba634..ee4fec7 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.412 2009/01/06 09:49:39 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.413 2009/01/13 20:30:03 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -3113,6 +3113,8 @@ MODULE_SCOPE int	Tcl_SwitchObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_TellObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_TimeObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
diff --git a/library/init.tcl b/library/init.tcl
index 2d8e303..74fd5f4 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
 # Default system startup file for Tcl-based applications.  Defines
 # "unknown" procedure and auto-load facilities.
 #
-# RCS: @(#) $Id: init.tcl,v 1.118 2008/12/19 03:54:44 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.119 2009/01/13 20:30:04 dkf Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -113,8 +113,8 @@ namespace eval tcl {
     }
 }
 
-# TIP #329: [try] and [throw]
-# These are *temporary* implementations, to be replaced with ones in C and
+# TIP #329: [try]
+# This is a *temporary* implementation, to be replaced with one in C and
 # bytecode at a later date before 8.6.0
 namespace eval ::tcl::control {
     # These are not local, since this allows us to [uplevel] a [catch] rather
@@ -125,20 +125,7 @@ namespace eval ::tcl::control {
 
     variable magicCodes { ok 0 error 1 return 2 break 3 continue 4 }
 
-    namespace export throw try
-
-    # ::tcl::control::throw --
-    #
-    #	Creates an error with machine-readable "code" parts and
-    #	human-readable "message" parts.
-    #
-    # Arguments:
-    #	throw -		list describing errorcode
-    #	message -	Human-readable version of error
-    proc throw {type message} {
-	return -code error -errorcode $type -errorinfo $message -level 1 \
-	    $message
-    }
+    namespace export try
 
     # ::tcl::control::try --
     #
@@ -306,7 +293,7 @@ namespace eval ::tcl::control {
 	return -options $_opts $_em
     }
 }
-namespace import ::tcl::control::*
+namespace import ::tcl::control::try
 
 # Windows specific end of initialization
 
diff --git a/tests/error.test b/tests/error.test
index dfb466f..6125dd4 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -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: error.test,v 1.17 2008/12/16 22:07:58 dkf Exp $
+# RCS: @(#) $Id: error.test,v 1.18 2009/01/13 20:30:04 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -263,6 +263,21 @@ test error-8.4 {throw behaves as error does at level > 0} {
 	}
     }
 } {}
+test error-8.5 {throw syntax checks} -returnCodes error -body {
+    throw
+} -result {wrong # args: should be "throw type message"}
+test error-8.6 {throw syntax checks} -returnCodes error -body {
+    throw a
+} -result {wrong # args: should be "throw type message"}
+test error-8.7 {throw syntax checks} -returnCodes error -body {
+    throw a b c
+} -result {wrong # args: should be "throw type message"}
+test error-8.8 {throw syntax checks} -returnCodes error -body {
+    throw "not a \{ list" foo
+} -result {unmatched open brace in list}
+test error-8.9 {throw syntax checks} -returnCodes error -body {
+    throw {} foo
+} -result {type must be non-empty list}
 
 # simple try tests: body completes with code ok