* generic/tclCmdAH.c (Tcl_CatchObjCmd, Tcl_ErrorObjCmd):

        Updated to call the new TclGet/SetReturnOptions routines to do
        much of their work.

        * generic/tclInt.h (TclGetReturnOptions,TclSetReturnOptions):
        * generic/tclResult.c (TclGetReturnOptions,TclSetReturnOptions):
        New utility routines to get/set the return options of an interp.
        Intent is that these routines will be converted to public routines
        after TIP approval.

        * generic/tclCmdMZ.c (TclProcessReturn,TclMergeReturnOptions):
        * generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions):
        Move internal utility routines from tclCmdMZ.c to tclResult.c.

        * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp):
        * generic/tclResult.c (TclTransferResult):      Rework so that
        iPtr->returnOpts can be NULL when there are no special options.

        * generic/tclResult.c (TclRestoreInterpState):  Plug potential
        memory leak.

6 files changed, 395 insertions, 280 deletions

diff --git a/ChangeLog b/ChangeLog
index 6328979..f843ea2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,26 @@
+2004-10-21  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclCmdAH.c (Tcl_CatchObjCmd, Tcl_ErrorObjCmd):
+	Updated to call the new TclGet/SetReturnOptions routines to do
+	much of their work.
+
+	* generic/tclInt.h (TclGetReturnOptions,TclSetReturnOptions):
+	* generic/tclResult.c (TclGetReturnOptions,TclSetReturnOptions):
+	New utility routines to get/set the return options of an interp.
+	Intent is that these routines will be converted to public routines
+	after TIP approval.
+
+	* generic/tclCmdMZ.c (TclProcessReturn,TclMergeReturnOptions):
+	* generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions):
+	Move internal utility routines from tclCmdMZ.c to tclResult.c.
+
+	* generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp):
+	* generic/tclResult.c (TclTransferResult):	Rework so that
+	iPtr->returnOpts can be NULL when there are no special options.
+
+	* generic/tclResult.c (TclRestoreInterpState):  Plug potential
+	memory leak.
+
 2004-10-21  Kevin B. Kenny  <kennykb@acm.org>
 
 	* generic/tclBasic.c: Various changes to [clock format] that,
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1a370bc..7451b69 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.130 2004/10/21 03:53:04 kennykb Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.131 2004/10/21 15:19:46 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -233,8 +233,7 @@ Tcl_CreateInterp()
     Tcl_IncrRefCount(iPtr->returnLevelKey);
     iPtr->returnOptionsKey = Tcl_NewStringObj("-options",-1);
     Tcl_IncrRefCount(iPtr->returnOptionsKey);
-    iPtr->returnOpts = Tcl_NewObj();
-    Tcl_IncrRefCount(iPtr->returnOpts);
+    iPtr->returnOpts = NULL;
     iPtr->errorInfo = NULL;
     iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1);
     Tcl_IncrRefCount(iPtr->eiVar);
@@ -992,7 +991,9 @@ DeleteInterpProc(interp)
 	Tcl_DecrRefCount(iPtr->errorInfo);
 	iPtr->errorInfo = NULL;
     }
-    Tcl_DecrRefCount(iPtr->returnOpts);
+    if (iPtr->returnOpts) {
+	Tcl_DecrRefCount(iPtr->returnOpts);
+    }
     Tcl_DecrRefCount(iPtr->returnCodeKey);
     Tcl_DecrRefCount(iPtr->returnErrorcodeKey);
     Tcl_DecrRefCount(iPtr->returnErrorinfoKey);
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 8d44139..e3c95bd 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.55 2004/10/18 21:15:35 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.56 2004/10/21 15:19:46 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -269,36 +269,9 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
 	}
     }
     if (objc == 4) {
-	Interp  *iPtr = (Interp *) interp;
-	Tcl_Obj *options = Tcl_DuplicateObj(iPtr->returnOpts);
-
-	if (result == TCL_RETURN) {
-	    Tcl_DictObjPut(NULL, options,
-		    iPtr->returnCodeKey, Tcl_NewIntObj(iPtr->returnCode));
-	    Tcl_DictObjPut(NULL, options,
-		    iPtr->returnLevelKey, Tcl_NewIntObj(iPtr->returnLevel));
-	} else {
-	    Tcl_DictObjPut(NULL, options,
-		    iPtr->returnCodeKey, Tcl_NewIntObj(result));
-	    Tcl_DictObjPut(NULL, options,
-		    iPtr->returnLevelKey, Tcl_NewIntObj(0));
-	}
-
-	if (result == TCL_ERROR) {
-	    /*
-	     * When result was an error, fill in any missing values
-	     * for -errorinfo, -errorcode, and -errorline
-	     */
-	    Tcl_DictObjPut(NULL, options,
-		    iPtr->returnErrorinfoKey, iPtr->errorInfo);
-	    Tcl_DictObjPut(NULL, options,
-		    iPtr->returnErrorcodeKey, iPtr->errorCode);
-	    Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey,
-			Tcl_NewIntObj(iPtr->errorLine));
-	}
-
-	if (NULL ==
-		Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) {
+	Tcl_Obj *options = TclGetReturnOptions(interp, result);
+	if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
+		options, 0)) {
 	    Tcl_DecrRefCount(options);
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendResult(interp,
@@ -582,31 +555,29 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv)
     int objc;			/* Number of arguments. */
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
-    Interp *iPtr = (Interp *) interp;
-    char *info;
-    int infoLen;
+    Tcl_Obj *options;
 
     if ((objc < 2) || (objc > 4)) {
 	Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
 	return TCL_ERROR;
     }
 
+    options = Tcl_NewStringObj("-code error -level 0", -1);
+
     if (objc >= 3) {		/* process the optional info argument */
-	info = Tcl_GetStringFromObj(objv[2], &infoLen);
-	if (infoLen > 0) {
-	    Tcl_AddObjErrorInfo(interp, info, infoLen);
-	    iPtr->flags |= ERR_ALREADY_LOGGED;
-	}
+	Tcl_ListObjAppendElement(NULL, options,
+		Tcl_NewStringObj("-errorinfo", -1));
+	Tcl_ListObjAppendElement(NULL, options, objv[2]);
     }
 
-    if (objc == 4) {
-	Tcl_SetObjErrorCode(interp, objv[3]);
-    } else {
-	Tcl_SetErrorCode(interp, "NONE", NULL);
+    if (objc == 4) {		/* process the optional code argument */
+	Tcl_ListObjAppendElement(NULL, options,
+		Tcl_NewStringObj("-errorcode", -1));
+	Tcl_ListObjAppendElement(NULL, options, objv[3]);
     }
 
     Tcl_SetObjResult(interp, objv[1]);
-    return TCL_ERROR;
+    return TclSetReturnOptions(interp, options);
 }
 
 /*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 9a8b617..03a4ccb 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.114 2004/10/18 21:15:35 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.115 2004/10/21 15:19:46 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -868,222 +868,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
 /*
  *----------------------------------------------------------------------
  *
- * TclProcessReturn --
- *
- *	Does the work of the [return] command based on the code,
- *	level, and returnOpts arguments.  Note that the code argument
- *	must agree with the -code entry in returnOpts and the level
- *	argument must agree with the -level entry in returnOpts, as
- *	is the case for values returned from TclMergeReturnOptions.
- *
- * Results:
- *	Returns the return code the [return] command should return.
- *
- * Side effects:
- * 	None.
- *
- *----------------------------------------------------------------------
- */
-int
-TclProcessReturn(interp, code, level, returnOpts)
-    Tcl_Interp *interp;
-    int code;
-    int level;
-    Tcl_Obj *returnOpts;
-{
-    Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *valuePtr;
-
-    /* Store the merged return options */
-    if (iPtr->returnOpts != returnOpts) {
-	Tcl_DecrRefCount(iPtr->returnOpts);
-	iPtr->returnOpts = returnOpts;
-	Tcl_IncrRefCount(iPtr->returnOpts);
-    }
-
-    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_SetObjErrorCode(interp, valuePtr);
-	} else {
-	    Tcl_SetErrorCode(interp, "NONE", NULL);
-	}
-
-	valuePtr = NULL;
-	Tcl_DictObjGet(NULL, iPtr->returnOpts,
-		iPtr->returnErrorlineKey, &valuePtr);
-	if (valuePtr != NULL) {
-	    Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
-	}
-    }
-    if (level != 0) {
-	iPtr->returnLevel = level;
-	iPtr->returnCode = code;
-	return TCL_RETURN;
-    }
-    return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclMergeReturnOptions --
- *
- *	Parses, checks, and stores the options to the [return] command.
- *
- * Results:
- *	Returns TCL_ERROR is any of the option values are invalid.
- *	Otherwise, returns TCL_OK, and writes the returnOpts, code,
- *	and level values to the pointers provided.
- *
- * Side effects:
- * 	None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
-    Tcl_Interp *interp;		/* Current interpreter. */
-    int objc;			/* Number of arguments. */
-    Tcl_Obj *CONST objv[];	/* Argument objects. */
-    Tcl_Obj **optionsPtrPtr;	/* If not NULL, points to space for a
-				 * (Tcl_Obj *) where the pointer to the
-				 * merged return options dictionary should
-				 * be written */
-    int *codePtr;		/* If not NULL, points to space where the
-				 * -code value should be written */
-    int *levelPtr;		/* If not NULL, points to space where the
-				 * -level value should be written */
-{
-    Interp *iPtr = (Interp *) interp;
-    int code=TCL_OK;
-    int level = 1;
-    Tcl_Obj *valuePtr;
-    Tcl_Obj *returnOpts = Tcl_NewObj();
-
-    for (;  objc > 1;  objv += 2, objc -= 2) {
-	int optLen;
-	CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
-	int compareLen;
-	CONST char *compare = Tcl_GetStringFromObj(
-		iPtr->returnOptionsKey, &compareLen);
-
-	if ((optLen == compareLen) && (strcmp(opt, compare) == 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_ResetResult(interp);
-		Tcl_AppendResult(interp, "bad ",
-			compare, " value: expected dictionary but got \"",
-			TclGetString(objv[1]), "\"", (char *) NULL);
-		goto error;
-	    }
-
-	    while (!done) {
-		Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
-		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
-	    }
-
-	    valuePtr = NULL;
-	    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr);
-	    if (valuePtr != NULL) {
-		dict = valuePtr;
-		Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey);
-		goto nestedOptions;
-	    }
-
-	} else {
-	    Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
-	}
-    }
-
-    /* Check for bogus -code value */
-    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr);
-    if ((valuePtr != NULL) 
-	    && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
-	static CONST char *returnCodes[] = {
-	    "ok", "error", "return", "break", "continue", NULL
-	};
-
-	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
-		NULL, TCL_EXACT, &code)) {
-	    /* Value is not a legal return code */
-	    Tcl_ResetResult(interp);
-	    Tcl_AppendResult(interp, "bad completion code \"",
-		    TclGetString(valuePtr),
-		    "\": must be ok, error, return, break, ",
-		    "continue, or an integer", (char *) NULL);
-	    goto error;
-	}
-	Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey);
-    }
-
-    /* Check for bogus -level value */
-    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr);
-    if (valuePtr != NULL) {
-	if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) 
-		|| (level < 0)) {
-	    /* Value is not a legal level */
-	    Tcl_ResetResult(interp);
-	    Tcl_AppendResult(interp, "bad -level value: ",
-		"expected non-negative integer but got \"",
-		TclGetString(valuePtr), "\"", (char *) NULL);
-	    goto error;
-	}
-	Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey);
-    }
-
-    /* 
-     * Convert [return -code return -level X] to
-     * [return -code ok -level X+1]
-     */
-    if (code == TCL_RETURN) {
-	level++;
-	code = TCL_OK;
-    }
-
-    if (codePtr != NULL) {
-	*codePtr = code;
-    }
-    if (levelPtr != NULL) {
-	*levelPtr = level;
-    }
-    if (optionsPtrPtr == NULL) {
-	/* Not passing back the options (?!), so clean them up */
-	Tcl_DecrRefCount(returnOpts);
-    } else {
-	*optionsPtrPtr = returnOpts;
-    }
-    return TCL_OK;
-
-error:
-    Tcl_DecrRefCount(returnOpts);
-    return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * Tcl_SourceObjCmd --
  *
  *	This procedure is invoked to process the "source" Tcl command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f2dc36e..90f02ac 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.184 2004/10/21 03:53:04 kennykb Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.185 2004/10/21 15:19:46 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1740,6 +1740,8 @@ EXTERN void		TclFinalizeAsync _ANSI_ARGS_((void));
 EXTERN void		TclFinalizeSynchronization _ANSI_ARGS_((void));
 EXTERN void		TclFinalizeLock _ANSI_ARGS_((void));
 EXTERN void		TclFinalizeThreadData _ANSI_ARGS_((void));
+EXTERN Tcl_Obj *	TclGetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
+			    int result));
 EXTERN int		TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *pattern, Tcl_Obj *unquotedPrefix, 
 			    int globFlags, Tcl_GlobTypeData* types));
@@ -1912,6 +1914,8 @@ EXTERN int		TclRestoreInterpState _ANSI_ARGS_ ((
 			    Tcl_Interp *interp, TclInterpState state));
 EXTERN TclInterpState	TclSaveInterpState _ANSI_ARGS_ ((
 			    Tcl_Interp *interp, int status));
+EXTERN int		TclSetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
+			    Tcl_Obj *options));
 EXTERN VOID             TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
 			    int result));
 EXTERN int		TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/generic/tclResult.c b/generic/tclResult.c
index de474f7..f2841d9 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.17 2004/10/19 21:54:07 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.18 2004/10/21 15:19:47 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -122,14 +122,23 @@ TclRestoreInterpState(interp, state)
 
     iPtr->returnLevel = statePtr->returnLevel;
     iPtr->returnCode = statePtr->returnCode;
+    if (iPtr->errorInfo) {
+	Tcl_DecrRefCount(iPtr->errorInfo);
+    }
     iPtr->errorInfo = statePtr->errorInfo;
     if (iPtr->errorInfo) {
 	Tcl_IncrRefCount(iPtr->errorInfo);
     }
+    if (iPtr->errorCode) {
+	Tcl_DecrRefCount(iPtr->errorCode);
+    }
     iPtr->errorCode = statePtr->errorCode;
     if (iPtr->errorCode) {
 	Tcl_IncrRefCount(iPtr->errorCode);
     }
+    if (iPtr->returnOpts) {
+	Tcl_DecrRefCount(iPtr->returnOpts);
+    }
     iPtr->returnOpts = statePtr->returnOpts;
     if (iPtr->returnOpts) {
 	Tcl_IncrRefCount(iPtr->returnOpts);
@@ -1052,6 +1061,326 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessReturn --
+ *
+ *	Does the work of the [return] command based on the code,
+ *	level, and returnOpts arguments.  Note that the code argument
+ *	must agree with the -code entry in returnOpts and the level
+ *	argument must agree with the -level entry in returnOpts, as
+ *	is the case for values returned from TclMergeReturnOptions.
+ *
+ * Results:
+ *	Returns the return code the [return] command should return.
+ *
+ * Side effects:
+ * 	None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclProcessReturn(interp, code, level, returnOpts)
+    Tcl_Interp *interp;
+    int code;
+    int level;
+    Tcl_Obj *returnOpts;
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *valuePtr;
+
+    /* Store the merged return options */
+    if (iPtr->returnOpts != returnOpts) {
+	if (iPtr->returnOpts) {
+	    Tcl_DecrRefCount(iPtr->returnOpts);
+	}
+	iPtr->returnOpts = returnOpts;
+	Tcl_IncrRefCount(iPtr->returnOpts);
+    }
+
+    if (code == TCL_ERROR) {
+	Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		iPtr->returnErrorinfoKey, &valuePtr);
+	if (valuePtr != NULL) {
+	    int infoLen;
+	    (void) Tcl_GetStringFromObj(valuePtr, &infoLen);
+	    if (infoLen) {
+		if (iPtr->errorInfo) {
+		    Tcl_DecrRefCount(iPtr->errorInfo);
+		}
+		iPtr->errorInfo = valuePtr;
+		Tcl_IncrRefCount(iPtr->errorInfo);
+		iPtr->flags |= ERR_ALREADY_LOGGED;
+	    }
+	}
+	Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		iPtr->returnErrorcodeKey, &valuePtr);
+	if (valuePtr != NULL) {
+	    Tcl_SetObjErrorCode(interp, valuePtr);
+	} else {
+	    Tcl_SetErrorCode(interp, "NONE", NULL);
+	}
+
+	Tcl_DictObjGet(NULL, iPtr->returnOpts,
+		iPtr->returnErrorlineKey, &valuePtr);
+	if (valuePtr != NULL) {
+	    Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
+	}
+    }
+    if (level != 0) {
+	iPtr->returnLevel = level;
+	iPtr->returnCode = code;
+	return TCL_RETURN;
+    }
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMergeReturnOptions --
+ *
+ *	Parses, checks, and stores the options to the [return] command.
+ *
+ * Results:
+ *	Returns TCL_ERROR is any of the option values are invalid.
+ *	Otherwise, returns TCL_OK, and writes the returnOpts, code,
+ *	and level values to the pointers provided.
+ *
+ * Side effects:
+ * 	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+    Tcl_Obj **optionsPtrPtr;	/* If not NULL, points to space for a
+				 * (Tcl_Obj *) where the pointer to the
+				 * merged return options dictionary should
+				 * be written */
+    int *codePtr;		/* If not NULL, points to space where the
+				 * -code value should be written */
+    int *levelPtr;		/* If not NULL, points to space where the
+				 * -level value should be written */
+{
+    Interp *iPtr = (Interp *) interp;
+    int code=TCL_OK;
+    int level = 1;
+    Tcl_Obj *valuePtr;
+    Tcl_Obj *returnOpts = Tcl_NewObj();
+
+    for (;  objc > 1;  objv += 2, objc -= 2) {
+	int optLen;
+	CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
+	int compareLen;
+	CONST char *compare = Tcl_GetStringFromObj(
+		iPtr->returnOptionsKey, &compareLen);
+
+	if ((optLen == compareLen) && (strcmp(opt, compare) == 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_ResetResult(interp);
+		Tcl_AppendResult(interp, "bad ",
+			compare, " value: expected dictionary but got \"",
+			TclGetString(objv[1]), "\"", (char *) NULL);
+		goto error;
+	    }
+
+	    while (!done) {
+		Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
+		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
+	    }
+
+	    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr);
+	    if (valuePtr != NULL) {
+		dict = valuePtr;
+		Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey);
+		goto nestedOptions;
+	    }
+
+	} else {
+	    Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
+	}
+    }
+
+    /* Check for bogus -code value */
+    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr);
+    if ((valuePtr != NULL) 
+	    && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
+	static CONST char *returnCodes[] = {
+	    "ok", "error", "return", "break", "continue", NULL
+	};
+
+	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
+		NULL, TCL_EXACT, &code)) {
+	    /* Value is not a legal return code */
+	    Tcl_ResetResult(interp);
+	    Tcl_AppendResult(interp, "bad completion code \"",
+		    TclGetString(valuePtr),
+		    "\": must be ok, error, return, break, ",
+		    "continue, or an integer", (char *) NULL);
+	    goto error;
+	}
+	Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey);
+    }
+
+    /* Check for bogus -level value */
+    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr);
+    if (valuePtr != NULL) {
+	if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) 
+		|| (level < 0)) {
+	    /* Value is not a legal level */
+	    Tcl_ResetResult(interp);
+	    Tcl_AppendResult(interp, "bad -level value: ",
+		"expected non-negative integer but got \"",
+		TclGetString(valuePtr), "\"", (char *) NULL);
+	    goto error;
+	}
+	Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey);
+    }
+
+    /* 
+     * Convert [return -code return -level X] to
+     * [return -code ok -level X+1]
+     */
+    if (code == TCL_RETURN) {
+	level++;
+	code = TCL_OK;
+    }
+
+    if (codePtr != NULL) {
+	*codePtr = code;
+    }
+    if (levelPtr != NULL) {
+	*levelPtr = level;
+    }
+    if (optionsPtrPtr == NULL) {
+	/* Not passing back the options (?!), so clean them up */
+	Tcl_DecrRefCount(returnOpts);
+    } else {
+	*optionsPtrPtr = returnOpts;
+    }
+    return TCL_OK;
+
+error:
+    Tcl_DecrRefCount(returnOpts);
+    return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclGetReturnOptions --
+ *
+ *	Packs up the interp state into a dictionary of return options.
+ *
+ * Results:
+ *	A dictionary of return options.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetReturnOptions(interp, result)
+    Tcl_Interp *interp;
+    int result;
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *options;
+
+    if (iPtr->returnOpts) {
+	options = Tcl_DuplicateObj(iPtr->returnOpts);
+    } else {
+	options = Tcl_NewObj();
+    }
+
+    if (result == TCL_RETURN) {
+	Tcl_DictObjPut(NULL, options,
+		iPtr->returnCodeKey, Tcl_NewIntObj(iPtr->returnCode));
+	Tcl_DictObjPut(NULL, options,
+		iPtr->returnLevelKey, Tcl_NewIntObj(iPtr->returnLevel));
+    } else {
+	Tcl_DictObjPut(NULL, options,
+		iPtr->returnCodeKey, Tcl_NewIntObj(result));
+	Tcl_DictObjPut(NULL, options,
+		iPtr->returnLevelKey, Tcl_NewIntObj(0));
+    }
+
+    if (result == TCL_ERROR) {
+	/*
+	 * When result was an error, fill in any missing values
+	 * for -errorinfo, -errorcode, and -errorline
+	 */
+	Tcl_DictObjPut(NULL, options,
+		iPtr->returnErrorinfoKey, iPtr->errorInfo);
+	Tcl_DictObjPut(NULL, options,
+		iPtr->returnErrorcodeKey, iPtr->errorCode);
+	Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey,
+		Tcl_NewIntObj(iPtr->errorLine));
+    }
+    return options;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclSetReturnOptions --
+ *
+ *	Accepts an interp and a  dictionary of return options, and sets
+ *	the return options of the interp to match the dictionary.
+ *
+ * Results:
+ *	A standard status code.  Usually TCL_OK, but TCL_ERROR if an
+ *	invalid option value was found in the dictionary.  If a -level
+ *	value of 0 is in the dictionary, then the -code value in the
+ *	dictionary will be returned (TCL_OK default).
+ *
+ * Side effects:
+ *	Sets the state of the interp.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclSetReturnOptions(interp, options)
+    Tcl_Interp *interp;
+    Tcl_Obj *options;
+{
+    int objc, level, code;
+    Tcl_Obj **objv, *mergedOpts;
+
+    if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv)
+	    || (objc % 2)) {
+	Tcl_ResetResult(interp);
+	Tcl_AppendResult(interp, "expected dict but got \"",
+		Tcl_GetString(options), "\"", NULL);
+	code = TCL_ERROR;
+    } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
+	    &mergedOpts, &code, &level)) {
+	code = TCL_ERROR;
+    } else {
+	code = TclProcessReturn(interp, code, level, mergedOpts);
+    }
+
+    Tcl_DecrRefCount(options);
+    return code;
+}
+
+/*
  *-------------------------------------------------------------------------
  *
  * TclTransferResult --
@@ -1093,7 +1422,8 @@ TclTransferResult(sourceInterp, result, targetInterp)
 				 * should be stored.  If source and target
 				 * are the same, nothing is done. */
 {
-    Interp *iPtr;
+    Interp *siPtr = (Interp *) sourceInterp;
+    Interp *tiPtr = (Interp *) targetInterp;
 
     if (sourceInterp == targetInterp) {
 	return;
@@ -1107,29 +1437,31 @@ TclTransferResult(sourceInterp, result, targetInterp)
 	 * chain, not just a simple error message.
 	 */
 
-	iPtr = (Interp *) sourceInterp;
-        if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
+        if ((siPtr->flags & ERR_ALREADY_LOGGED) == 0) {
             Tcl_AddErrorInfo(sourceInterp, "");
         }
-        iPtr->flags &= ~(ERR_ALREADY_LOGGED);
+        siPtr->flags &= ~(ERR_ALREADY_LOGGED);
         
         Tcl_ResetResult(targetInterp);
         
-	if (iPtr->errorInfo) {
-	    ((Interp *) targetInterp)->errorInfo = iPtr->errorInfo;
-	    Tcl_IncrRefCount(((Interp *) targetInterp)->errorInfo);
+	if (siPtr->errorInfo) {
+	    tiPtr->errorInfo = siPtr->errorInfo;
+	    Tcl_IncrRefCount(tiPtr->errorInfo);
 	}
 
-	if (iPtr->errorCode) {
-	    Tcl_SetObjErrorCode(targetInterp, iPtr->errorCode);
+	if (siPtr->errorCode) {
+	    Tcl_SetObjErrorCode(targetInterp, siPtr->errorCode);
 	}
     }
 
     /* This may need examination for safety */
-    Tcl_DecrRefCount( ((Interp *) targetInterp)->returnOpts );
-    ((Interp *) targetInterp)->returnOpts = 
-	    ((Interp *) sourceInterp)->returnOpts;
-    Tcl_IncrRefCount( ((Interp *) targetInterp)->returnOpts );
+    if (tiPtr->returnOpts ) {
+	Tcl_DecrRefCount(tiPtr->returnOpts );
+    }
+    tiPtr->returnOpts = siPtr->returnOpts;
+    if (tiPtr->returnOpts ) {
+	Tcl_IncrRefCount(tiPtr->returnOpts );
+    }
 
     Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
     Tcl_ResetResult(sourceInterp);