Move the implementation of [try] from Tcl to C. Not yet bytecoded.

6 files changed, 524 insertions, 204 deletions

diff --git a/ChangeLog b/ChangeLog
index 19582a6..78eb759 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2009-03-09  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCmdMZ.c (Tcl_TryObjCmd, TclNRTryObjCmd): Moved the
+	implementation of [try] from Tcl code into C. Still lacks a bytecode
+	version, but should be better than what was before.
+
 2009-03-04  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclZlib.c (TclZlibCmd): Checksums are defined to be unsigned
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b1a8d35..9f4d0dc 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.385 2009/02/03 23:34:33 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.386 2009/03/09 09:12:39 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -210,6 +210,7 @@ static const CmdInfo builtInCmds[] = {
     {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	NULL,	1},
     {"throw",		Tcl_ThrowObjCmd,	NULL,			NULL,	1},
     {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
+    {"try",		Tcl_TryObjCmd,		NULL,			TclNRTryObjCmd,	1},
     {"unset",		Tcl_UnsetObjCmd,	NULL,			NULL,	1},
     {"uplevel",		Tcl_UplevelObjCmd,	NULL,			TclNRUplevelObjCmd,	1},
     {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	1},
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 5a6f947..dbff659 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,12 +15,20 @@
  * 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.180 2009/02/25 14:56:05 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.181 2009/03/09 09:12:39 dkf Exp $
  */
 
 #include "tclInt.h"
 #include "tclRegexp.h"
 
+static inline Tcl_Obj *	During(Tcl_Interp *interp, int resultCode,
+			    Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
+static int		TryPostBody(ClientData data[], Tcl_Interp *interp,
+			    int result);
+static int		TryPostFinal(ClientData data[], Tcl_Interp *interp,
+			    int result);
+static int		TryPostHandler(ClientData data[], Tcl_Interp *interp,
+			    int result);
 static int		UniCharIsAscii(int character);
 
 /*
@@ -4026,14 +4034,13 @@ Tcl_TimeObjCmd(
     return TCL_OK;
 }
 
-#if 0 /* not yet implemented */
 /*
  *----------------------------------------------------------------------
  *
- * Tcl_TryObjCmd --
+ * Tcl_TryObjCmd, TclNRTryObjCmd --
  *
  *	This procedure is invoked to process the "try" Tcl command. See the
- *	user documentation for details on what it does.
+ *	user documentation (or TIP #329) for details on what it does.
  *
  * Results:
  *	A standard Tcl object result.
@@ -4056,14 +4063,498 @@ Tcl_TryObjCmd(
 
 int
 TclNRTryObjCmd(
-    ClientData dummy,		/* Not used. */
+    ClientData clientData,	/* Not used. */
     Tcl_Interp *interp,		/* Current interpreter. */
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
+    Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
+    int i, bodyShared, haveHandlers, dummy, code;
+    static const char *handlerNames[] = {
+	"finally", "on", "trap", NULL
+    };
+    enum Handlers {
+	TryFinally, TryOn, TryTrap
+    };
+    static const char *exceptionNames[] = {
+	"ok", "error", "return", "break", "continue", NULL
+    };
+
+    /*
+     * Parse the arguments. The handlers are passed to subsequent callbacks as
+     * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix,
+     * bindVariables, script), and the finally script is just passed as it is.
+     */
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv,
+		"body ?handler ...? ?finally script?");
+	return TCL_ERROR;
+    }
+    bodyObj = objv[1];
+    handlersObj = Tcl_NewObj();
+    bodyShared = 0;
+    haveHandlers = 0;
+    for (i=2 ; i<objc ; i++) {
+	int type;
+	Tcl_Obj *handlerItems[5];
+
+	if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type",
+		0, &type) != TCL_OK) {
+	    Tcl_DecrRefCount(handlersObj);
+	    return TCL_ERROR;
+	}
+	switch ((enum Handlers) type) {
+	case TryFinally:	/* finally script */
+	    if (i < objc-2) {
+		Tcl_AppendResult(interp, "finally clause must be last", NULL);
+		Tcl_DecrRefCount(handlersObj);
+		return TCL_ERROR;
+	    } else if (i == objc-1) {
+		Tcl_AppendResult(interp, "wrong # args to finally clause: ",
+			"must be \"", TclGetString(objv[0]),
+			" ... finally script\"", NULL);
+		Tcl_DecrRefCount(handlersObj);
+		return TCL_ERROR;
+	    }
+	    finallyObj = objv[++i];
+	    break;
+
+	case TryOn:		/* on code variableList script */
+	    if (i > objc-4) {
+		Tcl_AppendResult(interp, "wrong # args to on clause: ",
+			"must be \"", TclGetString(objv[0]),
+			" ... on code variableList script\"", NULL);
+		Tcl_DecrRefCount(handlersObj);
+		return TCL_ERROR;
+	    }
+	    if (Tcl_GetIntFromObj(NULL, objv[i+1], &code) != TCL_OK
+		    && Tcl_GetIndexFromObj(NULL, objv[i+1], exceptionNames,
+			    "code", 0, &code) != TCL_OK) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"bad code '%s': must be integer, \"ok\", \"error\", "
+			"\"return\", \"break\" or \"continue\"",
+			Tcl_GetString(objv[i+1])));
+		Tcl_DecrRefCount(handlersObj);
+		return TCL_ERROR;
+	    }
+	    handlerItems[2] = NULL;
+	    goto commonHandler;
+
+	case TryTrap:		/* trap pattern variableList script */
+	    if (i > objc-4) {
+		Tcl_AppendResult(interp, "wrong # args to trap clause: ",
+			"must be \"... trap pattern variableList script\"",
+			NULL);
+		Tcl_DecrRefCount(handlersObj);
+		return TCL_ERROR;
+	    }
+	    code = 1;
+	    if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"bad prefix '%s': must be a list",
+			Tcl_GetString(objv[i+1])));
+		Tcl_DecrRefCount(handlersObj);
+		return TCL_ERROR;
+	    }
+	    handlerItems[2] = objv[i+1];
+
+	commonHandler:
+	    if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
+		Tcl_DecrRefCount(handlersObj);
+		return TCL_ERROR;
+	    }
+
+	    handlerItems[0] = objv[i];			/* type */
+	    TclNewIntObj(handlerItems[1], code);	/* returnCode */
+	    if (handlerItems[2] == NULL) {		/* errorCodePrefix */
+		TclNewObj(handlerItems[2]);
+	    }
+	    handlerItems[3] = objv[i+2];		/* bindVariables */
+	    handlerItems[4] = objv[i+3];		/* script */
+
+	    bodyShared = !strcmp(TclGetString(objv[i+3]), "-");
+	    Tcl_ListObjAppendElement(NULL, handlersObj,
+		    Tcl_NewListObj(5, handlerItems));
+	    haveHandlers = 1;
+	    i += 3;
+	    break;
+	}
+    }
+    if (bodyShared) {
+	Tcl_AppendResult(interp,
+		"last non-finally clause must not have a body of \"-\"",
+		NULL);
+	Tcl_DecrRefCount(handlersObj);
+	return TCL_ERROR;
+    }
+    if (!haveHandlers) {
+	Tcl_DecrRefCount(handlersObj);
+	handlersObj = NULL;
+    }
+
+    /*
+     * Execute the body.
+     */
+
+    Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj, objv[0],
+	    NULL);
+    return TclNREvalObjEx(interp, bodyObj, 0,
+	    ((Interp *) interp)->cmdFramePtr, 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * During --
+ *
+ *	This helper function patches together the updates to the interpreter's
+ *	return options that are needed when things fail during the processing
+ *	of a handler or finally script for the [try] command.
+ *
+ * Returns:
+ *	The new option dictionary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline Tcl_Obj *
+During(
+    Tcl_Interp *interp,
+    int resultCode,		/* The result code from the just-evaluated
+				 * script. */
+    Tcl_Obj *oldOptions,	/* The old option dictionary. */
+    Tcl_Obj *errorInfo)		/* An object to append to the errorinfo and
+				 * release, or NULL if nothing is to be added.
+				 * Designed to be used with Tcl_ObjPrintf. */
+{
+    Tcl_Obj *during, *options;
+
+    if (errorInfo != NULL) {
+	Tcl_AppendObjToErrorInfo(interp, errorInfo);
+    }
+    options = Tcl_GetReturnOptions(interp, resultCode);
+    TclNewLiteralStringObj(during, "-during");
+    Tcl_IncrRefCount(during);
+    Tcl_DictObjPut(interp, options, during, oldOptions);
+    Tcl_DecrRefCount(during);
+    Tcl_IncrRefCount(options);
+    Tcl_DecrRefCount(oldOptions);
+    return options;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostBody --
+ *
+ *	Callback to handle the outcome of the execution of the body of a 'try'
+ *	command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostBody(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj;
+    int i, dummy, code;
+
+    handlersObj = data[0];
+    finallyObj = data[1];
+    cmdObj = data[2];
+
+    /*
+     * Basic processing of the outcome of the script, including adding of
+     * errorinfo trace.
+     */
+
+    resultObj = Tcl_GetObjResult(interp);
+    Tcl_IncrRefCount(resultObj);
+    if (result == TCL_ERROR) {
+	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		"\n    (\"%s\" body line %d)", TclGetString(cmdObj),
+		Tcl_GetErrorLine(interp)));
+    }
+    if (handlersObj != NULL || finallyObj != NULL) {
+	options = Tcl_GetReturnOptions(interp, result);
+	Tcl_IncrRefCount(options);
+    } else {
+	options = NULL;
+    }
+    Tcl_ResetResult(interp);
+
+    /*
+     * Handle the results.
+     */
+
+    if (handlersObj != NULL) {
+	int numHandlers, found = 0;
+	Tcl_Obj **handlers, **info;
+
+	Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
+	for (i=0 ; i<numHandlers ; i++) {
+	    Tcl_Obj *handlerObj;
+
+	    Tcl_ListObjGetElements(NULL, handlers[i], &dummy, &info);
+	    if (!found) {
+		Tcl_GetIntFromObj(NULL, info[1], &code);
+		if (code != result) {
+		    continue;
+		}
+
+		/*
+		 * When processing an error, must additionally perform
+		 * list-prefix matching of the errorcode list.
+		 */
+
+		if (code == TCL_ERROR) {
+		    Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
+		    int len1, len2, j;
+
+		    TclNewLiteralStringObj(errorCodeName, "-errorcode");
+		    Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
+		    Tcl_DecrRefCount(errorCodeName);
+		    Tcl_ListObjGetElements(NULL, info[2], &len1, &bits1);
+		    if (Tcl_ListObjGetElements(NULL, errcode, &len2,
+			    &bits2) != TCL_OK) {
+			continue;
+		    }
+		    if (len2 < len1) {
+		    didNotMatch:
+			continue;
+		    }
+		    for (j=0 ; j<len1 ; j++) {
+			if (strcmp(TclGetString(bits1[j]),
+				TclGetString(bits2[j])) != 0) {
+			    /*
+			     * Really want continue outerloop, but C doesn't
+			     * give us that.
+			     */
+
+			    goto didNotMatch;
+			}
+		    }
+		}
+
+		found = 1;
+	    }
+
+	    /*
+	     * Now we need to scan forward over "-" bodies. Note that we've
+	     * already checked that the last body is not a "-", so this search
+	     * will terminate successfully.
+	     */
+
+	    if (!strcmp(TclGetString(info[4]), "-")) {
+		continue;
+	    }
+
+	    /*
+	     * Bind the variables. We already know this is a list of variable
+	     * names, but it might be empty.
+	     */
+
+	    Tcl_ResetResult(interp);
+	    result = TCL_ERROR;
+	    Tcl_ListObjLength(NULL, info[3], &dummy);
+	    if (dummy > 0) {
+		Tcl_Obj *varName;
+
+		Tcl_ListObjIndex(NULL, info[3], 0, &varName);
+		if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
+			TCL_LEAVE_ERR_MSG) == NULL) {
+		    goto handlerFailed;
+		}
+		if (dummy > 1) {
+		    Tcl_ListObjIndex(NULL, info[3], 1, &varName);
+		    if (Tcl_ObjSetVar2(interp, varName, NULL, options,
+			    TCL_LEAVE_ERR_MSG) == NULL) {
+			goto handlerFailed;
+		    }
+		}
+	    }
+
+	    /*
+	     * Evaluate the handler body and process the outcome. Note that we
+	     * need to keep the type of handler for debugging purposes.
+	     */
+
+	    handlerObj = info[0];
+	    Tcl_IncrRefCount(handlerObj);
+	    Tcl_DecrRefCount(handlersObj);
+	    Tcl_NRAddCallback(interp, TryPostHandler, cmdObj, options,
+		    handlerObj, finallyObj);
+	    return TclNREvalObjEx(interp, info[4], 0,
+		    ((Interp *) interp)->cmdFramePtr, -1);
+
+	handlerFailed:
+	    options = During(interp, result, options, NULL);
+	    break;
+	}
+
+	/*
+	 * No handler matched; get rid of the list of handlers.
+	 */
+
+	Tcl_DecrRefCount(handlersObj);
+    }
+
+    /*
+     * Process the finally clause.
+     */
+
+    if (finallyObj != NULL) {
+	Tcl_NRAddCallback(interp, TryPostFinal, resultObj, INT2PTR(result),
+		options, cmdObj);
+	return TclNREvalObjEx(interp, finallyObj, 0,
+		((Interp *) interp)->cmdFramePtr, -1);
+    }
+
+    /*
+     * Install the correct result/options into the interpreter and clean up
+     * any temporary storage.
+     */
+
+    if (options != NULL) {
+	result = TclProcessReturn(interp, result, 0, options);
+	Tcl_DecrRefCount(options);
+    }
+    if (resultObj != NULL) {
+	Tcl_SetObjResult(interp, resultObj);
+	Tcl_DecrRefCount(resultObj);
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostHandler --
+ *
+ *	Callback to handle the outcome of the execution of a handler of a
+ *	'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostHandler(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Tcl_Obj *resultObj, *cmdObj, *options, *handlerObj;
+    Tcl_Obj *finallyObj;
+
+    cmdObj = data[0];
+    options = data[1];
+    handlerObj = data[2];
+    finallyObj = data[3];
+
+    /*
+     * The handler result completely substitutes for the result of the body.
+     */
+
+    resultObj = Tcl_GetObjResult(interp);
+    Tcl_IncrRefCount(resultObj);
+    if (result == TCL_ERROR) {
+	options = During(interp, result, options, Tcl_ObjPrintf(
+		"\n    (\"%s ... %s\" handler line %d)",
+		TclGetString(cmdObj), TclGetString(handlerObj),
+		Tcl_GetErrorLine(interp)));
+    } else {
+	Tcl_DecrRefCount(options);
+	options = Tcl_GetReturnOptions(interp, result);
+	Tcl_IncrRefCount(options);
+    }
+    Tcl_DecrRefCount(handlerObj);
+
+    /*
+     * Process the finally clause if it is present.
+     */
+
+    if (finallyObj != NULL) {
+	Tcl_NRAddCallback(interp, TryPostFinal, resultObj, INT2PTR(result),
+		options, cmdObj);
+	return TclNREvalObjEx(interp, finallyObj, 0,
+		((Interp *) interp)->cmdFramePtr, -1);
+    }
+
+    /*
+     * Install the correct result/options into the interpreter and clean up
+     * any temporary storage.
+     */
+
+    result = TclProcessReturn(interp, result, 0, options);
+    Tcl_DecrRefCount(options);
+    Tcl_SetObjResult(interp, resultObj);
+    Tcl_DecrRefCount(resultObj);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostFinal --
+ *
+ *	Callback to handle the outcome of the execution of the finally script
+ *	of a 'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostFinal(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int finalResult)
+{
+    Tcl_Obj *resultObj, *options, *cmdObj;
+    int result;
+
+    resultObj = data[0];
+    result = PTR2INT(data[1]);
+    options = data[2];
+    cmdObj = data[3];
+
+    /*
+     * If the result wasn't OK, we need to adjust the result options.
+     */
+
+    if (finalResult != TCL_OK) {
+	Tcl_DecrRefCount(resultObj);
+	resultObj = NULL;
+	result = finalResult;
+	if (result == TCL_ERROR) {
+	    options = During(interp, result, options, Tcl_ObjPrintf(
+		    "\n    (\"%s ... finally\" body line %d)",
+		    TclGetString(cmdObj), Tcl_GetErrorLine(interp)));
+	} else {
+	    Tcl_Obj *origOptions = options;
+
+	    options = Tcl_GetReturnOptions(interp, result);
+	    Tcl_IncrRefCount(options);
+	    Tcl_DecrRefCount(origOptions);
+	}
+    }
+
+    /*
+     * Install the correct result/options into the interpreter and clean up
+     * any temporary storage.
+     */
 
+    result = TclProcessReturn(interp, result, 0, options);
+    Tcl_DecrRefCount(options);
+    if (resultObj != NULL) {
+	Tcl_SetObjResult(interp, resultObj);
+	Tcl_DecrRefCount(resultObj);
+    }
+    return result;
 }
-#endif /* not yet implemented */
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3de0ea2..3f7a2dc 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.417 2009/02/13 03:22:52 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.418 2009/03/09 09:12:39 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -2585,6 +2585,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
@@ -3126,6 +3127,9 @@ MODULE_SCOPE int	Tcl_TimeObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_TraceObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_TryObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_UnloadObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
diff --git a/library/init.tcl b/library/init.tcl
index 3ec3079..6ca4873 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.120 2009/01/16 20:44:25 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.121 2009/03/09 09:12:39 dkf Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -113,188 +113,6 @@ namespace eval tcl {
     }
 }
 
-# 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
-    # than [catch] the [uplevel]ing of something, resulting in a cleaner
-    # -errorinfo:
-    variable em {}
-    variable opts {}
-
-    variable magicCodes { ok 0 error 1 return 2 break 3 continue 4 }
-
-    namespace export try
-
-    # ::tcl::control::try --
-    #
-    #	Advanced error handling construct.
-    #
-    # Arguments:
-    #	See try(n) for details
-    proc try {args} {
-	variable magicCodes
-
-	# ----- Parse arguments -----
-
-	set trybody [lindex $args 0]
-	set finallybody {}
-	set handlers [list]
-	set i 1
-
-	while {$i < [llength $args]} {
-	    switch -- [lindex $args $i] {
-		"on" {
-		    incr i
-		    set code [lindex $args $i]
-		    if {[dict exists $magicCodes $code]} {
-			set code [dict get $magicCodes $code]
-		    } elseif {![string is integer -strict $code]} {
-			set msgPart [join [dict keys $magicCodes] {", "}]
-			error "bad code '[lindex $args $i]': must be\
-			    integer or \"$msgPart\""
-		    }
-		    lappend handlers [lrange $args $i $i] \
-			[format %d $code] {} {*}[lrange $args $i+1 $i+2]
-		    incr i 3
-		}
-		"trap" {
-		    incr i
-		    if {![string is list [lindex $args $i]]} {
-			error "bad prefix '[lindex $args $i]':\
-			    must be a list"
-		    }
-		    lappend handlers [lrange $args $i $i] 1 \
-			{*}[lrange $args $i $i+2]
-		    incr i 3
-		}
-		"finally" {
-		    incr i
-		    set finallybody [lindex $args $i]
-		    incr i
-		    break
-		}
-		default {
-		    error "bad handler '[lindex $args $i]': must be\
-			\"on code varlist body\", or\
-			\"trap prefix varlist body\""
-		}
-	    }
-	}
-
-	if {($i != [llength $args]) || ([lindex $handlers end] eq "-")} {
-	    error "wrong # args: should be\
-		\"try body ?handler ...? ?finally body?\""
-	}
-
-	# ----- Execute 'try' body -----
-
-	variable em
-	variable opts
-	set EMVAR  [namespace which -variable em]
-	set OPTVAR [namespace which -variable opts]
-	set code [uplevel 1 [list ::catch $trybody $EMVAR $OPTVAR]]
-
-	if {$code == 1} {
-	    set line [dict get $opts -errorline]
-	    dict append opts -errorinfo \
-		"\n    (\"[lindex [info level 0] 0]\" body line $line)"
-	}
-
-	# Keep track of the original error message & options
-	set _em $em
-	set _opts $opts
-
-	# ----- Find and execute handler -----
-
-	set errorcode {}
-	if {[dict exists $opts -errorcode]} {
-	    set errorcode [dict get $opts -errorcode]
-	}
-	set found false
-	foreach {descrip oncode pattern varlist body} $handlers {
-	    if {!$found} {
-		if {
-		    ($code != $oncode) || ([lrange $pattern 0 end] ne
-		    [lrange $errorcode 0 [llength $pattern]-1] )
-		} then {
-		    continue
-		}
-	    }
-	    set found true
-	    if {$body eq "-"} {
-		continue
-	    }
-
-	    # Handler found ...
-
-	    # Assign trybody results into variables
-	    lassign $varlist resultsVarName optionsVarName
-	    if {[llength $varlist] >= 1} {
-		upvar 1 $resultsVarName resultsvar
-		set resultsvar $em
-	    }
-	    if {[llength $varlist] >= 2} {
-		upvar 1 $optionsVarName optsvar
-		set optsvar $opts
-	    }
-
-	    # Execute the handler
-	    set code [uplevel 1 [list ::catch $body $EMVAR $OPTVAR]]
-
-	    if {$code == 1} {
-		set line [dict get $opts -errorline]
-		dict append opts -errorinfo \
-		    "\n    (\"[lindex [info level 0] 0] ... $descrip\"\
-		    body line $line)"
-		# On error chain to original outcome
-		dict set opts -during $_opts
-	    }
-
-	    # Handler result replaces the original result (whether success or
-	    # failure); capture context of original exception for reference.
-	    set _em $em
-	    set _opts $opts
-
-	    # Handler has been executed - stop looking for more
-	    break
-	}
-
-	# No catch handler found -- error falls through to caller
-	# OR catch handler executed -- result falls through to caller
-
-	# ----- If we have a finally block then execute it -----
-
-	if {$finallybody ne {}} {
-	    set code [uplevel 1 [list ::catch $finallybody $EMVAR $OPTVAR]]
-
-	    # Finally result takes precedence except on success
-
-	    if {$code == 1} {
-		set line [dict get $opts -errorline]
-		dict append opts -errorinfo \
-		    "\n    (\"[lindex [info level 0] 0] ... finally\"\
-		    body line $line)"
-		# On error chain to original outcome
-		dict set opts -during $_opts
-	    }
-	    if {$code != 0} {
-		set _em $em
-		set _opts $opts
-	    }
-
-	    # Otherwise our result is not affected
-	}
-
-	# Propagate the error or the result of the executed catch body to the
-	# caller.
-	dict incr _opts -level
-	return -options $_opts $_em
-    }
-}
-namespace import ::tcl::control::try
-
 # Windows specific end of initialization
 
 if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
diff --git a/tests/error.test b/tests/error.test
index 6125dd4..4eb765e 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.18 2009/01/13 20:30:04 dkf Exp $
+# RCS: @(#) $Id: error.test,v 1.19 2009/03/09 09:12:39 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -396,38 +396,38 @@ test error-13.1 {try with no arguments} -body {
     # warning: error message may change
     try
 } -returnCodes error -match glob -result {wrong # args: *}
-test error-13.2 {try with body only (ok) } {
+test error-13.2 {try with body only (ok)} {
     try list
 } {}
-test error-13.3 {try with missing finally body } -body {
+test error-13.3 {try with missing finally body} -body {
     # warning: error message may change
     try list finally
-} -returnCodes error -match glob -result {wrong # args: *}
-test error-13.4 {try with bad handler keyword } -body {
+} -returnCodes error -match glob -result {wrong # args to finally clause: *}
+test error-13.4 {try with bad handler keyword} -body {
     # warning: error message may change
     try list then a b c
 } -returnCodes error -match glob -result {bad handler *}
-test error-13.5 {try with partial handler #1 } -body {
+test error-13.5 {try with partial handler #1} -body {
     # warning: error message may change
     try list on
-} -returnCodes error -match glob -result {bad code *}
-test error-13.6 {try with partial handler #2 } -body {
+} -returnCodes error -match glob -result {wrong # args to on clause: *}
+test error-13.6 {try with partial handler #2} -body {
     # warning: error message may change
     try list on error
-} -returnCodes error -match glob -result {wrong # args: *}
-test error-13.7 {try with partial handler #3 } -body {
+} -returnCodes error -match glob -result {wrong # args to on clause: *}
+test error-13.7 {try with partial handler #3} -body {
     # warning: error message may change
     try list on error {em opts}
-} -returnCodes error -match glob -result {wrong # args: *}
+} -returnCodes error -match glob -result {wrong # args to on clause: *}
 test error-13.8 {try with multiple handlers and finally (ok)} {
     try list on error {} {} trap {} {} {} finally {}
 } {}
 test error-13.9 {last handler body can't be a fallthrough #1} -body {
     try list on error {} {} on break {} - 
-} -returnCodes error -match glob -result {wrong # args: *}
+} -returnCodes error -result {last non-finally clause must not have a body of "-"}
 test error-13.10 {last handler body can't be a fallthrough #2} -body {
     try list on error {} {} on break {} - finally { list d e f }
-} -returnCodes error -match glob -result {wrong # args: *}
+} -returnCodes error -result {last non-finally clause must not have a body of "-"}
 
 # try tests - multiple handlers (left-to-right matching, only one runs)