diff options
| -rw-r--r-- | ChangeLog | 31 | ||||
| -rw-r--r-- | generic/tclBasic.c | 3 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 101 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 | ||||
| -rw-r--r-- | library/init.tcl | 23 | ||||
| -rw-r--r-- | tests/error.test | 17 |
6 files changed, 144 insertions, 35 deletions
@@ -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 |