* 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.

1 files changed, 1 insertions, 217 deletions

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.