Patch 876451: restores performance of [return]. Also allows forms

        such as [return -code error $msg] to be bytecompiled.

        * generic/tclInt.h:     Factored Tcl_ReturnObjCmd() into two pieces:
        * generic/tclCmdMZ.c:   TclMergeReturnOptions(), which can parse the
        options to [return], check their validity, and create the
        corresponding return options dictionary, and TclProcessReturn(),
        which takes that return options dictionary and performs the
        [return] operation.

        * generic/tclCompCmds.c:        Rewrote TclCompileReturnCmd() to
        call TclMergeReturnOptions() at compile time so the return options
        dictionary is computed at compile time (when it is fully known).
        The dictionary is pushed on the stack along with the result, and
        the code and level values are included in the bytecode as operands.
        Also supports optimized compilation of un-[catch]ed [return]s from
        procs with default options into the INST_DONE instruction.

        * generic/tclExecute.c: Rewrote INST_RETURN instruction to retrieve
        the code and level operands, pop the return options from the stack,
        and call TclProcessReturn() to perform the [return] operation.

        * generic/tclCompile.h: New utilities include TclEmitInt4 macro
        * generic/tclCompile.c: and TclWordKnownAtCompileTime().

1 files changed, 154 insertions, 64 deletions

diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 1077418..f880057 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.98 2003/12/24 04:18:18 davygrvy Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.99 2004/01/13 23:15:02 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -844,29 +844,138 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
     int objc;			/* Number of arguments. */
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
-    Interp *iPtr = (Interp *) interp;
     int code, level;
+    Tcl_Obj *returnOpts;
+
+    /*
+     * General syntax: [return ?-option value ...? ?result?]
+     * An even number of words means an explicit result argument is present.
+     */
+    int explicitResult = (0 == (objc % 2));
+    int numOptionWords = objc - 1 - explicitResult;
+
+    if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1,
+	    &returnOpts, &code, &level)) {
+	return TCL_ERROR;
+    }
+
+    code = TclProcessReturn(interp, code, level, returnOpts);
+    if (explicitResult) {
+	Tcl_SetObjResult(interp, objv[objc-1]);
+    }
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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:
+ *	When the return code is TCL_ERROR, the values of ::errorInfo
+ *	and ::errorCode may be updated.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclProcessReturn(interp, code, level, returnOpts)
+    Tcl_Interp *interp;
+    int code;
+    int level;
+    Tcl_Obj *returnOpts;
+{
+    Interp *iPtr = (Interp *) interp;
     Tcl_Obj *valuePtr;
 
-    /* Start with the default options */
-    if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
+    /* Store the merged return options */
+    if (iPtr->returnOpts != returnOpts) {
 	Tcl_DecrRefCount(iPtr->returnOpts);
-	iPtr->returnOpts = iPtr->defaultReturnOpts;
+	iPtr->returnOpts = returnOpts;
 	Tcl_IncrRefCount(iPtr->returnOpts);
     }
 
-    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);
+    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;
     }
-    
+    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, level, size;
+    Tcl_Obj *valuePtr;
+    Tcl_Obj *returnOpts = Tcl_DuplicateObj(iPtr->defaultReturnOpts);
+
     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)) {
+	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;
@@ -876,38 +985,33 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
 	    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_AppendStringsToObj(Tcl_GetObjResult(interp), "bad ",
+			compare, " value: expected dictionary but got \"",
 			Tcl_GetString(objv[1]), "\"", (char *) NULL);
 		return TCL_ERROR;
 	    }
 
 	    while (!done) {
-		Tcl_DictObjPut(NULL, iPtr->returnOpts, keyPtr, valuePtr);
+		Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
 		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
 	    }
 
 	    valuePtr = NULL;
-	    Tcl_DictObjGet(NULL, iPtr->returnOpts,
-		    iPtr->returnOptionsKey, &valuePtr);
+	    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr);
 	    if (valuePtr != NULL) {
 		dict = valuePtr;
-		Tcl_DictObjRemove(NULL, iPtr->returnOpts,
-			iPtr->returnOptionsKey);
+		Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey);
 		goto nestedOptions;
 	    }
 
 	} else {
-	    Tcl_DictObjPut(NULL, iPtr->returnOpts, objv[0], objv[1]);
+	    Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
 	}
     }
 
     /* Check for bogus -code value */
-    Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
+    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr);
     if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code)) {
 	static CONST char *returnCodes[] = {
 	    "ok", "error", "return", "break", "continue", NULL
@@ -916,9 +1020,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
 	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 completion code \"",
@@ -928,17 +1029,14 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
 	    return TCL_ERROR;
 	}
 	/* Have a legal string value for a return code; convert to integer */
-	Tcl_DictObjPut(NULL, iPtr->returnOpts,
+	Tcl_DictObjPut(NULL, returnOpts,
 		iPtr->returnCodeKey, Tcl_NewIntObj(code));
     }
 
     /* Check for bogus -level value */
-    Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
+    Tcl_DictObjGet(NULL, 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 \"",
@@ -952,43 +1050,35 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
      */
     if (code == TCL_RETURN) {
 	level++;
-	Tcl_DictObjPut(NULL, iPtr->returnOpts,
+	Tcl_DictObjPut(NULL, returnOpts,
 		iPtr->returnLevelKey, Tcl_NewIntObj(level));
-	Tcl_DictObjPut(NULL, iPtr->returnOpts,
+	Tcl_DictObjPut(NULL, 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;
+    /*
+     * Check if we just have the default options.  If so, use them.
+     * A dictionary equality test would be more robust, but seems
+     * tricky, to say the least.
+     */
+    Tcl_DictObjSize(NULL, returnOpts, &size);
+    if (size == 2 && code == TCL_OK && level == 1) {
+	Tcl_DecrRefCount(returnOpts);
+	returnOpts = iPtr->defaultReturnOpts;
     }
-
-    if (objc == 1) {
-	Tcl_SetObjResult(interp, objv[0]);
+    if (codePtr != NULL) {
+	*codePtr = code;
     }
-    return code;
-
+    if (levelPtr != NULL) {
+	*levelPtr = level;
+    }
+    if ((optionsPtrPtr == NULL) && (returnOpts != iPtr->defaultReturnOpts)) {
+	/* not passing back the options (?!), so clean them up */
+	Tcl_DecrRefCount(returnOpts);
+    } else {
+	*optionsPtrPtr = returnOpts;
+    }
+    return TCL_OK;
 }
 
 /*