summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-01-13 20:30:03 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-01-13 20:30:03 (GMT)
commit2982ceeb51c99eb042c8477125d3d1da80b84387 (patch)
tree01ade12b49117b7dbe4027f9ddff331b91731046
parent91fcbdbc1ce2836f8df968af33ce13bff991a90b (diff)
downloadtcl-2982ceeb51c99eb042c8477125d3d1da80b84387.zip
tcl-2982ceeb51c99eb042c8477125d3d1da80b84387.tar.gz
tcl-2982ceeb51c99eb042c8477125d3d1da80b84387.tar.bz2
Move [throw] implementation into C.
-rw-r--r--ChangeLog31
-rw-r--r--generic/tclBasic.c3
-rw-r--r--generic/tclCmdMZ.c101
-rw-r--r--generic/tclInt.h4
-rw-r--r--library/init.tcl23
-rw-r--r--tests/error.test17
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