* generic/tclBasic.c: Implementation of TIP 90, which

        * generic/tclCmdAH.c:           extends the [catch] and [return]
        * generic/tclCompCmds.c:        commands to enable creation of a
        * generic/tclExecute.c:         proc that is a replacement for
        * generic/tclInt.h:             [return]. [Patch 531640]
        * generic/tclProc.c:
        * generic/tclResult.c:
        * tests/cmdAH.test:
        * tests/cmdMZ.test:
        * tests/error.test:
        * tests/proc-old.test:

        * library/tcltest/tcltest.tcl: The -returnCodes option to [test]
        failed to recognize the symbolic name "ok" for return code 0.

14 files changed, 479 insertions, 135 deletions

diff --git a/ChangeLog b/ChangeLog
index 04ad752..8c7f9ec 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2003-05-05  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c:		Implementation of TIP 90, which
+	* generic/tclCmdAH.c:		extends the [catch] and [return]
+	* generic/tclCompCmds.c:	commands to enable creation of a
+	* generic/tclExecute.c:		proc that is a replacement for
+	* generic/tclInt.h:		[return]. [Patch 531640]
+	* generic/tclProc.c:
+	* generic/tclResult.c:
+	* tests/cmdAH.test:
+	* tests/cmdMZ.test:
+	* tests/error.test:
+	* tests/proc-old.test:
+
+        * library/tcltest/tcltest.tcl: The -returnCodes option to [test]
+        failed to recognize the symbolic name "ok" for return code 0.
+
 2003-05-05  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
 
 	* generic/tclBasic.c (Tcl_HideCommand): Fixed error message for
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index bd8efdc..5551c45 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,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.80 2003/05/05 16:48:54 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.81 2003/05/05 20:54:38 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -337,9 +337,27 @@ Tcl_CreateInterp()
     iPtr->framePtr = NULL;
     iPtr->varFramePtr = NULL;
     iPtr->activeVarTracePtr = NULL;
-    iPtr->returnCode = TCL_OK;
-    iPtr->errorInfo = NULL;
-    iPtr->errorCode = NULL;
+
+    iPtr->returnCodeKey = Tcl_NewStringObj("-code",-1);
+    Tcl_IncrRefCount(iPtr->returnCodeKey);
+    iPtr->returnErrorcodeKey = Tcl_NewStringObj("-errorcode",-1);
+    Tcl_IncrRefCount(iPtr->returnErrorcodeKey);
+    iPtr->returnErrorinfoKey = Tcl_NewStringObj("-errorinfo",-1);
+    Tcl_IncrRefCount(iPtr->returnErrorinfoKey);
+    iPtr->returnErrorlineKey = Tcl_NewStringObj("-errorline",-1);
+    Tcl_IncrRefCount(iPtr->returnErrorlineKey);
+    iPtr->returnLevelKey = Tcl_NewStringObj("-level",-1);
+    Tcl_IncrRefCount(iPtr->returnLevelKey);
+    iPtr->returnOptionsKey = Tcl_NewStringObj("-options",-1);
+    Tcl_IncrRefCount(iPtr->returnOptionsKey);
+    iPtr->defaultReturnOpts = Tcl_NewDictObj();
+    Tcl_DictObjPut(NULL, iPtr->defaultReturnOpts,
+	    iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK));
+    Tcl_DictObjPut(NULL, iPtr->defaultReturnOpts,
+	    iPtr->returnLevelKey, Tcl_NewIntObj(1));
+    Tcl_IncrRefCount(iPtr->defaultReturnOpts);
+    iPtr->returnOpts = iPtr->defaultReturnOpts;
+    Tcl_IncrRefCount(iPtr->returnOpts);
 
     iPtr->appendResult = NULL;
     iPtr->appendAvl = 0;
@@ -1062,14 +1080,14 @@ DeleteInterpProc(interp)
     interp->result = NULL;
     Tcl_DecrRefCount(iPtr->objResultPtr);
     iPtr->objResultPtr = NULL;
-    if (iPtr->errorInfo != NULL) {
-	ckfree(iPtr->errorInfo);
-        iPtr->errorInfo = NULL;
-    }
-    if (iPtr->errorCode != NULL) {
-	ckfree(iPtr->errorCode);
-        iPtr->errorCode = NULL;
-    }
+    Tcl_DecrRefCount(iPtr->returnOpts);
+    Tcl_DecrRefCount(iPtr->defaultReturnOpts);
+    Tcl_DecrRefCount(iPtr->returnCodeKey);
+    Tcl_DecrRefCount(iPtr->returnErrorcodeKey);
+    Tcl_DecrRefCount(iPtr->returnErrorinfoKey);
+    Tcl_DecrRefCount(iPtr->returnErrorlineKey);
+    Tcl_DecrRefCount(iPtr->returnLevelKey);
+    Tcl_DecrRefCount(iPtr->returnOptionsKey);
     if (iPtr->appendResult != NULL) {
 	ckfree(iPtr->appendResult);
         iPtr->appendResult = NULL;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 0536dd2..3731974 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -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: tclCmdAH.c,v 1.31 2003/04/16 23:33:43 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.32 2003/05/05 20:54:38 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -234,10 +234,12 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
     Tcl_Obj *varNamePtr = NULL;
+    Tcl_Obj *optionVarNamePtr = NULL;
     int result;
 
-    if ((objc != 2) && (objc != 3)) {
-	Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
+    if ((objc < 2) || (objc > 4)) {
+	Tcl_WrongNumArgs(interp, 1, objv,
+		"script ?resultVarName? ?optionVarName?");
 	return TCL_ERROR;
     }
 
@@ -247,21 +249,74 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
      * stack rendering objv invalid.
      */
     
-    if (objc == 3) {
+    if (objc >= 3) {
 	varNamePtr = objv[2];
     }
+    if (objc == 4) {
+	optionVarNamePtr = objv[3];
+    }
 
     result = Tcl_EvalObjEx(interp, objv[1], 0);
     
-    if (objc == 3) {
-	if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
-		Tcl_GetObjResult(interp), 0) == NULL) {
+    if (objc >= 3) {
+	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+		Tcl_GetObjResult(interp), 0)) {
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendToObj(Tcl_GetObjResult(interp),  
 	            "couldn't save command result in variable", -1);
 	    return TCL_ERROR;
 	}
     }
+    if (objc == 4) {
+	Interp  *iPtr = (Interp *) interp;
+	Tcl_Obj *options = Tcl_DuplicateObj(iPtr->returnOpts);
+	Tcl_Obj *value = NULL;
+
+	if (result != TCL_RETURN) {
+	    Tcl_DictObjPut(NULL, options,
+		    iPtr->returnCodeKey, Tcl_NewIntObj(result));
+	    Tcl_DictObjPut(NULL, options,
+		    iPtr->returnLevelKey, Tcl_NewIntObj(0));
+	}
+
+	if (iPtr->flags & ERR_IN_PROGRESS) {
+	    value = NULL;
+	    Tcl_DictObjGet(NULL, options, iPtr->returnErrorinfoKey, &value);
+	    if (NULL == value) {
+		Tcl_DictObjPut(NULL, options, iPtr->returnErrorinfoKey,
+			Tcl_ObjGetVar2(interp, iPtr->execEnvPtr->errorInfo,
+			NULL, TCL_GLOBAL_ONLY));
+	    }
+	}
+
+	if (iPtr->flags & ERROR_CODE_SET) {
+	    value = NULL;
+	    Tcl_DictObjGet(NULL, options, iPtr->returnErrorcodeKey, &value);
+	    if (NULL == value) {
+		Tcl_DictObjPut(NULL, options, iPtr->returnErrorcodeKey,
+			Tcl_ObjGetVar2(interp, iPtr->execEnvPtr->errorCode,
+			NULL, TCL_GLOBAL_ONLY));
+	    }
+	}
+
+	if (result == TCL_ERROR) {
+	    value = NULL;
+	    Tcl_DictObjGet(NULL, options, iPtr->returnErrorlineKey, &value);
+	    if (NULL == value) {
+		Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey,
+			Tcl_NewIntObj(iPtr->errorLine));
+	    }
+	}
+
+	if (NULL ==
+		Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) {
+	    Tcl_DecrRefCount(options);
+	    Tcl_ResetResult(interp);
+	    Tcl_AppendToObj(Tcl_GetObjResult(interp),  
+	            "couldn't save return options in variable", -1);
+	    return TCL_ERROR;
+	}
+    }
 
     /*
      * Set the interpreter's object result to an integer object holding the
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 21b439c..3e9d8d0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -14,7 +14,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.86 2003/04/11 20:50:47 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.87 2003/05/05 20:54:38 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -934,74 +934,150 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
     Interp *iPtr = (Interp *) interp;
-    int optionLen, argLen, code, result;
-
-    if (iPtr->errorInfo != NULL) {
-	ckfree(iPtr->errorInfo);
-	iPtr->errorInfo = NULL;
+    int code, level;
+    Tcl_Obj *valuePtr;
+
+    /* Start with the default options */
+    if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
+	Tcl_DecrRefCount(iPtr->returnOpts);
+	iPtr->returnOpts = iPtr->defaultReturnOpts;
+	Tcl_IncrRefCount(iPtr->returnOpts);
     }
-    if (iPtr->errorCode != NULL) {
-	ckfree(iPtr->errorCode);
-	iPtr->errorCode = NULL;
+
+    objv++, objc--;
+    if (objc) {
+	/* We're going to add our options, so manage Tcl_Obj sharing */
+	Tcl_DecrRefCount(iPtr->returnOpts);
+	iPtr->returnOpts = Tcl_DuplicateObj(iPtr->returnOpts);
+	Tcl_IncrRefCount(iPtr->returnOpts);
     }
-    code = TCL_OK;
     
-    for (objv++, objc--;  objc > 1;  objv += 2, objc -= 2) {
-	char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
-	char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
-    	
-	if (strcmp(option, "-code") == 0) {
-	    register int c = arg[0];
-	    if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
-		code = TCL_OK;
-	    } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
-		code = TCL_ERROR;
-	    } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
-		code = TCL_RETURN;
-	    } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
-		code = TCL_BREAK;
-	    } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
-		code = TCL_CONTINUE;
-	    } else {
-		result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
-		        &code);
-		if (result != TCL_OK) {
-		    Tcl_ResetResult(interp);
-		    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-			    "bad completion code \"",
-			    Tcl_GetString(objv[1]),
-			    "\": must be ok, error, return, break, ",
-			    "continue, or an integer", (char *) NULL);
-		    return result;
-		}
+    for (;  objc > 1;  objv += 2, objc -= 2) {
+	int optLen;
+	CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
+	if ((optLen == 8) && (*opt == '-') && (strcmp(opt, "-options") == 0)) {
+	    Tcl_DictSearch search;
+	    int done = 0;
+	    Tcl_Obj *keyPtr;
+	    Tcl_Obj *dict = objv[1];
+
+	    nestedOptions:
+	    if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict,
+		    &search, &keyPtr, &valuePtr, &done)) {
+		/* Value is not a legal dictionary */
+		Tcl_DecrRefCount(iPtr->returnOpts);
+		iPtr->returnOpts = iPtr->defaultReturnOpts;
+		Tcl_IncrRefCount(iPtr->returnOpts);
+		Tcl_ResetResult(interp);
+		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+			"bad -options value: expected dictionary but got \"",
+			Tcl_GetString(objv[1]), "\"", (char *) NULL);
+		return TCL_ERROR;
+	    }
+
+	    while (!done) {
+		Tcl_DictObjPut(NULL, iPtr->returnOpts, keyPtr, valuePtr);
+		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
+	    }
+
+	    valuePtr = NULL;
+	    Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		    iPtr->returnOptionsKey, &valuePtr);
+	    if (valuePtr != NULL) {
+		dict = valuePtr;
+		Tcl_DictObjRemove(NULL, iPtr->returnOpts,
+			iPtr->returnOptionsKey);
+		goto nestedOptions;
 	    }
-	} else if (strcmp(option, "-errorinfo") == 0) {
-	    iPtr->errorInfo =
-		(char *) ckalloc((unsigned) (strlen(arg) + 1));
-	    strcpy(iPtr->errorInfo, arg);
-	} else if (strcmp(option, "-errorcode") == 0) {
-	    iPtr->errorCode =
-		(char *) ckalloc((unsigned) (strlen(arg) + 1));
-	    strcpy(iPtr->errorCode, arg);
+
 	} else {
+	    Tcl_DictObjPut(NULL, iPtr->returnOpts, objv[0], objv[1]);
+	}
+    }
+
+    /* Check for bogus -code value */
+    Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
+    if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code)) {
+	static CONST char *returnCodes[] = {
+	    "ok", "error", "return", "break", "continue"
+	};
+
+	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
+		NULL, TCL_EXACT, &code)) {
+	    /* Value is not a legal return code */
+	    Tcl_DecrRefCount(iPtr->returnOpts);
+	    iPtr->returnOpts = iPtr->defaultReturnOpts;
+	    Tcl_IncrRefCount(iPtr->returnOpts);
+	    Tcl_ResetResult(interp);
 	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-		    "bad option \"", option,
-		    "\": must be -code, -errorcode, or -errorinfo",
-		    (char *) NULL);
+		    "bad completion code \"",
+		    Tcl_GetString(valuePtr),
+		    "\": must be ok, error, return, break, ",
+		    "continue, or an integer", (char *) NULL);
 	    return TCL_ERROR;
 	}
+	/* Have a legal string value for a return code; convert to integer */
+	Tcl_DictObjPut(NULL, iPtr->returnOpts,
+		iPtr->returnCodeKey, Tcl_NewIntObj(code));
+    }
+
+    /* Check for bogus -level value */
+    Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
+    if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level) || (level < 0)) {
+	/* Value is not a legal level */
+	Tcl_DecrRefCount(iPtr->returnOpts);
+	iPtr->returnOpts = iPtr->defaultReturnOpts;
+	Tcl_IncrRefCount(iPtr->returnOpts);
+	Tcl_ResetResult(interp);
+	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+		"bad -level value: expected non-negative integer but got \"",
+		Tcl_GetString(valuePtr), "\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    /* 
+     * Convert [return -code return -level X] to
+     * [return -code ok -level X+1]
+     */
+    if (code == TCL_RETURN) {
+	level++;
+	Tcl_DictObjPut(NULL, iPtr->returnOpts,
+		iPtr->returnLevelKey, Tcl_NewIntObj(level));
+	Tcl_DictObjPut(NULL, iPtr->returnOpts,
+		iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK));
+    }
+
+    if (level == 0) {
+	if (code == TCL_ERROR) {
+	    valuePtr = NULL;
+	    Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		    iPtr->returnErrorinfoKey, &valuePtr);
+	    if (valuePtr != NULL) {
+		int infoLen;
+		CONST char *info = Tcl_GetStringFromObj(valuePtr,&infoLen);
+		if (infoLen) {
+		    Tcl_AddObjErrorInfo(interp, info, infoLen);
+		    iPtr->flags |= ERR_ALREADY_LOGGED;
+		}
+	    }
+	    valuePtr = NULL;
+	    Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		    iPtr->returnErrorcodeKey, &valuePtr);
+	    if (valuePtr != NULL) {
+		Tcl_SetVar2Ex(interp, "errorCode", NULL,
+			valuePtr, TCL_GLOBAL_ONLY);
+		iPtr->flags |= ERROR_CODE_SET;
+	    }
+	}
+    } else {
+	code = TCL_RETURN;
     }
-    
-    if (objc == 1) {
-	/*
-	 * Set the interpreter's object result. An inline version of
-	 * Tcl_SetObjResult.
-	 */
 
+    if (objc == 1) {
 	Tcl_SetObjResult(interp, objv[0]);
     }
-    iPtr->returnCode = code;
-    return TCL_RETURN;
+    return code;
+
 }
 
 /*
@@ -3851,7 +3927,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
 				 * information. */
 {
     Interp *iPtr = (Interp *) interp;
-    int stateCode;
+    Tcl_Obj *stateReturnOpts;
     Tcl_SavedResult state;
     TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
     int code;
@@ -3877,7 +3953,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
 
 	/*
 	 * Execute the command.  Save the interp's result used for the
-	 * command, including the value of iPtr->returnCode which may be
+	 * command, including the value of iPtr->returnOpts which may be
 	 * modified when Tcl_Eval is invoked. We discard any object
 	 * result the command returns.
 	 *
@@ -3887,7 +3963,8 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
 	 */
 
 	Tcl_SaveResult(interp, &state);
-	stateCode = iPtr->returnCode;
+	stateReturnOpts = iPtr->returnOpts;
+	Tcl_IncrRefCount(stateReturnOpts);
 	if (flags & TCL_TRACE_DESTROYED) {
 	    tcmdPtr->flags |= TCL_TRACE_DESTROYED;
 	}
@@ -3899,7 +3976,12 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
 	}
 
 	Tcl_RestoreResult(interp, &state);
-	iPtr->returnCode = stateCode;
+	if (iPtr->returnOpts != stateReturnOpts) {
+	    Tcl_DecrRefCount(iPtr->returnOpts);
+	    iPtr->returnOpts = stateReturnOpts;
+	    Tcl_IncrRefCount(iPtr->returnOpts);
+	}
+	Tcl_DecrRefCount(stateReturnOpts);
 	
 	Tcl_DStringFree(&cmd);
     }
@@ -4302,7 +4384,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
 	 */
 	if (call) {
 	    Tcl_SavedResult state;
-	    int stateCode;
+	    Tcl_Obj *stateReturnOpts;
 	    Tcl_DString cmd;
 	    Tcl_DString sub;
 	    int i;
@@ -4351,13 +4433,14 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
 	    
 	    /*
 	     * Execute the command.  Save the interp's result used for
-	     * the command, including the value of iPtr->returnCode which
+	     * the command, including the value of iPtr->returnOpts which
 	     * may be modified when Tcl_Eval is invoked.  We discard any
 	     * object result the command returns.
 	     */
 
 	    Tcl_SaveResult(interp, &state);
-	    stateCode = iPtr->returnCode;
+	    stateReturnOpts = iPtr->returnOpts;
+	    Tcl_IncrRefCount(stateReturnOpts);
 
 	    tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
 	    iPtr->flags    |= INTERP_TRACE_IN_PROGRESS;
@@ -4377,10 +4460,15 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
             if (traceCode == TCL_OK) {
 		/* Restore result if trace execution was successful */
 		Tcl_RestoreResult(interp, &state);
-		iPtr->returnCode = stateCode;
+		if (iPtr->returnOpts != stateReturnOpts) {
+		    Tcl_DecrRefCount(iPtr->returnOpts);
+		    iPtr->returnOpts = stateReturnOpts;
+		    Tcl_IncrRefCount(iPtr->returnOpts);
+		}
             } else {
 		Tcl_DiscardResult(&state);
 	    }
+	    Tcl_DecrRefCount(stateReturnOpts);
 
 	    Tcl_DStringFree(&cmd);
 	}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 709359d..139463f 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -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: tclCompCmds.c,v 1.48 2003/05/01 19:57:47 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.49 2003/05/05 20:54:38 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -246,11 +246,12 @@ TclCompileCatchCmd(interp, parsePtr, envPtr)
     int code;
     int savedStackDepth = envPtr->currStackDepth;
 
+    /*
+     * If syntax does not match what we expect for [catch], do not
+     * compile.  Let runtime checks determine if syntax has changed.
+     */
     if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendToObj(Tcl_GetObjResult(interp),
-	        "wrong # args: should be \"catch command ?varName?\"", -1);
-	return TCL_ERROR;
+	return TCL_OUT_LINE_COMPILE;
     }
 
     /*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 3d324a5..0697677 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -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: tclExecute.c,v 1.100 2003/04/28 12:34:25 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.101 2003/05/05 20:54:39 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -975,6 +975,11 @@ TclCompEvalObj(interp, objPtr)
 	 */
 	
 	codePtr->refCount++;
+	if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
+	    Tcl_DecrRefCount(iPtr->returnOpts);
+	    iPtr->returnOpts = iPtr->defaultReturnOpts;
+	    Tcl_IncrRefCount(iPtr->returnOpts);
+	}
 	iPtr->numLevels++;
 	result = TclExecuteByteCode(interp, codePtr);
 	iPtr->numLevels--;
@@ -1196,7 +1201,11 @@ TclExecuteByteCode(interp, codePtr)
 #endif
     switch (*pc) {
     case INST_RETURN:
-	iPtr->returnCode = TCL_OK;
+	if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
+	    Tcl_DecrRefCount(iPtr->returnOpts);
+	    iPtr->returnOpts = iPtr->defaultReturnOpts;
+	    Tcl_IncrRefCount(iPtr->returnOpts);
+	}
 	result = TCL_RETURN;
     case INST_DONE:
 	if (stackTop <= initStackTop) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 70b8106..c440202 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.126 2003/04/28 12:34:27 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.127 2003/05/05 20:54:40 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1206,12 +1206,9 @@ typedef struct Interp {
     ActiveVarTrace *activeVarTracePtr;
 				/* First in list of active traces for
 				 * interp, or NULL if no active traces. */
-    int returnCode;		/* Completion code to return if current
-				 * procedure exits with TCL_RETURN code. */
-    char *errorInfo;		/* Value to store in errorInfo if returnCode
-				 * is TCL_ERROR.  Malloc'ed, may be NULL */
-    char *errorCode;		/* Value to store in errorCode if returnCode
-				 * is TCL_ERROR.  Malloc'ed, may be NULL */
+    int unused2;		/* No longer used (was returnCode) */
+    char *unused3;		/* No longer used (was errorInfo) */
+    char *unused4;		/* No longer used (was errorCode) */
 
     /*
      * Information used by Tcl_AppendResult to keep track of partial
@@ -1305,6 +1302,18 @@ typedef struct Interp {
     int tracesForbiddingInline; /* Count of traces (in the list headed by
 				 * tracePtr) that forbid inline bytecode
 				 * compilation */
+
+    /* Fields used to manage extensible return options (TIP 90) */
+    Tcl_Obj *returnOpts;	/* A dictionary holding the options to the
+				 * last [return] command */
+    Tcl_Obj *defaultReturnOpts; /* Default [return] options */
+    Tcl_Obj *returnCodeKey;	/* holds "-code" */
+    Tcl_Obj *returnErrorcodeKey;	/* holds "-errorcode" */
+    Tcl_Obj *returnErrorinfoKey;	/* holds "-errorinfo" */
+    Tcl_Obj *returnErrorlineKey;	/* holds "-errorline" */
+    Tcl_Obj *returnLevelKey;	/* holds "-level" */
+    Tcl_Obj *returnOptionsKey;	/* holds "-options" */
+
     /*
      * Statistical information about the bytecode compiler and interpreter's
      * operation.
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 4e3d4b8..9f8d1e4 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclProc.c,v 1.44 2002/12/11 21:29:52 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.45 2003/05/05 20:54:40 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1077,7 +1077,6 @@ TclObjInterpProc(clientData, interp, objc, objv)
     }
 #endif /*TCL_COMPILE_DEBUG*/
 
-    iPtr->returnCode = TCL_OK;
     procPtr->refCount++;
     result = TclCompEvalObj(interp, procPtr->bodyPtr);
     procPtr->refCount--;
@@ -1409,8 +1408,8 @@ TclProcCleanupProc(procPtr)
  * TclUpdateReturnInfo --
  *
  *	This procedure is called when procedures return, and at other
- *	points where the TCL_RETURN code is used.  It examines fields
- *	such as iPtr->returnCode and iPtr->errorCode and modifies
+ *	points where the TCL_RETURN code is used.  It examines values
+ *	stored in the iPtr->returnOpts dictionary and modifies
  *	the real return status accordingly.
  *
  * Results:
@@ -1428,21 +1427,46 @@ TclUpdateReturnInfo(iPtr)
     Interp *iPtr;		/* Interpreter for which TCL_RETURN
 				 * exception is being processed. */
 {
-    int code;
+    int level, code = TCL_RETURN;
     char *errorCode;
+    Tcl_Obj *valuePtr;
 
-    code = iPtr->returnCode;
-    iPtr->returnCode = TCL_OK;
+    Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
+    Tcl_GetIntFromObj(NULL, valuePtr, &level);
+    level--;
+    if (level < 0) {
+	Tcl_Panic("TclUpdateReturnInfo: negative return level");
+    }
+    if (Tcl_IsShared(iPtr->returnOpts)) {
+	Tcl_DecrRefCount(iPtr->returnOpts);
+	iPtr->returnOpts = Tcl_DuplicateObj(iPtr->returnOpts);
+	Tcl_IncrRefCount(iPtr->returnOpts);
+    }
+    Tcl_DictObjPut(NULL, iPtr->returnOpts,
+	    iPtr->returnLevelKey, Tcl_NewIntObj(level));
+
+    if (level == 0) {
+	/* Now we've reached the level to return the requested -code */
+	Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
+	Tcl_GetIntFromObj(NULL, valuePtr, &code);
+    }
     if (code == TCL_ERROR) {
-	errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
-	Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
-	        NULL, Tcl_NewStringObj(errorCode, -1),
-		TCL_GLOBAL_ONLY);
+	Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		iPtr->returnErrorcodeKey, &valuePtr);
+	if (valuePtr == NULL) {
+	    Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
+	            NULL, Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY);
+	} else {
+	    Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
+	            NULL, valuePtr, TCL_GLOBAL_ONLY);
+	}
 	iPtr->flags |= ERROR_CODE_SET;
-	if (iPtr->errorInfo != NULL) {
+
+	Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		iPtr->returnErrorinfoKey, &valuePtr);
+	if (valuePtr != NULL) {
 	    Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
-	            NULL, Tcl_NewStringObj(iPtr->errorInfo, -1),
-		    TCL_GLOBAL_ONLY);
+	            NULL, valuePtr, TCL_GLOBAL_ONLY);
 	    iPtr->flags |= ERR_IN_PROGRESS;
 	}
     }
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 367ca80..4eb3c69 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclResult.c,v 1.5 2002/01/25 20:40:55 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.6 2003/05/05 20:54:40 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1046,7 +1046,12 @@ TclTransferResult(sourceInterp, result, targetInterp)
 	((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
     }
 
-    ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
+    /* This may need examination for safety */
+    Tcl_DecrRefCount( ((Interp *) targetInterp)->returnOpts );
+    ((Interp *) targetInterp)->returnOpts = 
+	    ((Interp *) sourceInterp)->returnOpts;
+    Tcl_IncrRefCount( ((Interp *) targetInterp)->returnOpts );
+
     Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
     Tcl_ResetResult(sourceInterp);
 }
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index f2151e9..f1f24ee 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -16,7 +16,7 @@
 # Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
 # All rights reserved.
 #
-# RCS: @(#) $Id: tcltest.tcl,v 1.81 2003/04/21 20:42:23 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.82 2003/05/05 20:54:40 dgp Exp $
 
 package require Tcl 8.3		;# uses [glob -directory]
 namespace eval tcltest {
@@ -1919,7 +1919,7 @@ proc tcltest::test {name description args} {
 	}
 
 	# Replace symbolic valies supplied for -returnCodes
-	foreach {strcode numcode} {normal 0 error 1 return 2 break 3 continue 4} {
+	foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
 	    set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
 	}
     } else {
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 0a0228b..e4fc0ce 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: cmdAH.test,v 1.31 2003/04/11 15:59:59 vincentdarley Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.32 2003/05/05 20:54:44 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -34,10 +34,13 @@ test cmdAH-0.2 {Tcl_BreakObjCmd, success} {
 
 test cmdAH-1.1 {Tcl_CatchObjCmd, errors} {
     list [catch {catch} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}}
 test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
     list [catch {catch foo bar baz} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {0 1}
+test cmdAH-1.3 {Tcl_CatchObjCmd, errors} {
+    list [catch {catch foo bar baz spaz} msg] $msg
+} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}}
 
 test cmdAH-2.1 {Tcl_CdObjCmd} {
     list [catch {cd foo bar} msg] $msg
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 0e65229..c6416df 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -11,13 +11,20 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: cmdMZ.test,v 1.13 2002/07/19 08:52:27 dkf Exp $
+# RCS: @(#) $Id: cmdMZ.test,v 1.14 2003/05/05 20:54:50 dgp Exp $
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
-    namespace import -force ::tcltest::*
+if {[catch {package require tcltest 2.0.2}]} {
+    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
+    return
 }
-set tcltest::testConstraints(nonLinuxOnly) \
+
+namespace eval ::tcl::test::cmdMZ {
+    namespace import ::tcltest::cleanupTests
+    namespace import ::tcltest::makeFile
+    namespace import ::tcltest::removeFile
+    namespace import ::tcltest::test
+
+set ::tcltest::testConstraints(nonLinuxOnly) \
 	[expr {![string equal Linux $tcl_platform(os)]}]
 
 # Tcl_PwdObjCmd
@@ -69,7 +76,113 @@ test cmdMZ-2.4 {Tcl_RenameObjCmd: success} {
     list [catch {r1} msg] $msg
 } {1 {invalid command name "r1"}}
 
-# The tests for Tcl_ReturnObjCmd are in proc-old.test
+# Some tests for Tcl_ReturnObjCmd are in proc-old.test
+
+test cmdMZ-return-1.0 {return checks for bad option values} -body {
+    return -options foo
+} -returnCodes error -match glob -result {bad -options value:*}
+test cmdMZ-return-1.1 {return checks for bad option values} -body {
+    return -code foo
+} -returnCodes error -match glob -result {bad completion code*}
+test cmdMZ-return-1.2 {return checks for bad option values} -body {
+    return -code 0x100000000
+} -returnCodes error -match glob -result {bad completion code*}
+test cmdMZ-return-1.3 {return checks for bad option values} -body {
+    return -level foo
+} -returnCodes error -match glob -result {bad -level value:*}
+test cmdMZ-return-1.4 {return checks for bad option values} -body {
+    return -level -1
+} -returnCodes error -match glob -result {bad -level value:*}
+test cmdMZ-return-1.5 {return checks for bad option values} -body {
+    return -level 3.1415926
+} -returnCodes error -match glob -result {bad -level value:*}
+
+proc dictSort {d} {
+    foreach k [lsort [dict keys $d]] {
+	lappend result $k [dict get $d $k]
+    }
+    return $result
+}
+
+test cmdMZ-return-2.0 {return option handling} {
+    list [catch return -> foo] [dictSort $foo]
+} {2 {-code 0 -level 1}}
+test cmdMZ-return-2.1 {return option handling} {
+    list [catch {return -bar soom} -> foo] [dictSort $foo]
+} {2 {-bar soom -code 0 -level 1}}
+test cmdMZ-return-2.2 {return option handling} {
+    list [catch {return -code return} -> foo] [dictSort $foo]
+} {2 {-code 0 -level 2}}
+test cmdMZ-return-2.3 {return option handling} {
+    list [catch {return -code return -level 10} -> foo] [dictSort $foo]
+} {2 {-code 0 -level 11}}
+test cmdMZ-return-2.4 {return option handling} -body {
+    return -level 0 -code error
+} -returnCodes error -result {}
+test cmdMZ-return-2.5 {return option handling} -body {
+    return -level 0 -code return
+} -returnCodes return -result {}
+test cmdMZ-return-2.6 {return option handling} -body {
+    return -level 0 -code break
+} -returnCodes break -result {}
+test cmdMZ-return-2.7 {return option handling} -body {
+    return -level 0 -code continue
+} -returnCodes continue -result {}
+test cmdMZ-return-2.8 {return option handling} -body {
+    return -level 0 -code -1
+} -returnCodes -1 -result {}
+test cmdMZ-return-2.9 {return option handling} -body {
+    return -level 0 -code 10
+} -returnCodes 10 -result {}
+test cmdMZ-return-2.10 {return option handling} {
+    list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
+} {1 {-code 1 -errorinfo {
+    while executing
+"return -level 0 -code error"} -errorline 1 -level 0}}
+test cmdMZ-return-2.11 {return option handling} {
+    list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
+} {3 {-code 3 -level 0}}
+test cmdMZ-return-2.12 {return option handling} -body {
+    return -level 0 -code error -options {-code ok}
+} -returnCodes ok -result {}
+test cmdMZ-return-2.13 {return option handling} -body {
+    return -level 0 -code error -options {-code foo}
+} -returnCodes error -match glob -result {bad completion code*}
+test cmdMZ-return-2.14 {return option handling} -body {
+    return -level 0 -code error -options {-code foo -options {-code break}}
+} -returnCodes break -result {}
+
+# Check that the result of a [return -options $opts $result] is
+# indistinguishable from that of the originally caught script, no
+# matter what the script is/does.  (TIP 90)
+set i 0
+foreach script {
+	{}
+	{format x}
+	{set}
+	{set a 1}
+	{error}
+	{error foo}
+	{error foo bar}
+	{error foo bar baz}
+	{return -level 0}
+	{return -code error}
+	{return -code error -errorinfo foo}
+	{return -code error -errorinfo foo -errorcode bar}
+	{return -code error -errorinfo foo -errorcode bar -errorline 10}
+	{return -options {x y z 2}}
+	{return -level 3 -code break sdf}
+} {
+    test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" {
+	set one [list [catch $script foo bar] $foo [dictSort $bar] \
+		$::errorCode $::errorInfo]
+	set two [list [catch {return -options $bar $foo} foo2 bar2] \
+		$foo2 [dictSort $bar2] $::errorCode $::errorInfo]
+	string equal $one $two
+    } 1
+    incr i
+}
+
 # The tests for Tcl_ScanObjCmd are in scan.test
 
 # Tcl_SourceObjCmd
@@ -127,7 +240,7 @@ test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} {
 } {1 2 3 4 5}
 test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} {
     split "a\}b\[c\{\]\$"
-} "a\\}b\\\[c\\{\\\]\\\$"
+} "a\\\}b\\\[c\\\{\\\]\\\$"
 test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} {
     split {} {}
 } {}
@@ -197,5 +310,7 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
 # The tests for Tcl_WhileObjCmd are in while.test
 
 # cleanup
-::tcltest::cleanupTests
+cleanupTests
+}
+namespace delete ::tcl::test::cmdMZ
 return
diff --git a/tests/error.test b/tests/error.test
index 1d5f9a0..1581f4c 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.9 2002/01/29 03:03:02 hobbs Exp $
+# RCS: @(#) $Id: error.test,v 1.10 2003/05/05 20:54:52 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -60,13 +60,13 @@ test error-1.5 {simple errors from commands} {
 } glorp
 
 test error-1.6 {simple errors from commands} {
-    catch {catch a b c} b
+    catch {catch a b c d} b
 } 1
 
 test error-1.7 {simple errors from commands} {
-    catch {catch a b c} b
+    catch {catch a b c d} b
     set b
-} {wrong # args: should be "catch command ?varName?"}
+} {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
 
 test error-1.8 {simple errors from commands} {nonPortable} {
     # This test is non-portable: it generates a memory fault on
@@ -124,10 +124,10 @@ test error-2.6 {errors in nested procedures} {
 
 test error-3.1 {errors in catch command} {
     list [catch {catch} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}}
 test error-3.2 {errors in catch command} {
     list [catch {catch a b c} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {0 1}
 test error-3.3 {errors in catch command} {
     catch {unset a}
     set a(0) 22
diff --git a/tests/proc-old.test b/tests/proc-old.test
index 0292103..81d20b6 100644
--- a/tests/proc-old.test
+++ b/tests/proc-old.test
@@ -14,7 +14,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: proc-old.test,v 1.10 2003/03/27 21:44:05 msofer Exp $
+# RCS: @(#) $Id: proc-old.test,v 1.11 2003/05/05 20:54:52 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -483,7 +483,7 @@ test proc-old-7.14 {return with special completion code} {
 "tproc2"} none}
 test proc-old-7.15 {return with special completion code} {
     list [catch {return -badOption foo message} msg] $msg
-} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}}
+} {2 message}
 
 test proc-old-8.1 {unset and undefined local arrays} {
     proc t1 {} {