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().

7 files changed, 410 insertions, 134 deletions

diff --git a/ChangeLog b/ChangeLog
index 6d423ae..6762c3c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,32 @@
 2004-01-13  Don Porter	<dgp@users.sourceforge.net>
 
+	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().
+	
+	End Patch 876451.
+
 	* generic/tclFileName.c (Tcl_GlobObjCmd):  Latest changes to
 	management of the interp result by Tcl_GetIndexFromObj() exposed
 	improper interp result management in the [glob] command procedure.
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;
 }
 
 /*
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index e3e9eb3..d5cceb4 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.52 2003/12/24 04:18:19 davygrvy Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.53 2004/01/13 23:15:02 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2346,12 +2346,9 @@ TclCompileRegexpCmd(interp, parsePtr, envPtr)
  *
  * Results:
  *	The return value is a standard Tcl result, which is TCL_OK if the
- *	compilation was successful.  If the particular return command is
- *	too complex for this function (ie, return with any flags like "-code"
- *	or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
- *	the command should be compiled "out of line" (eg, not byte compiled).
- *	If an error occurs then the interpreter's result contains a standard
- *	error message.
+ *	compilation was successful.  If analysis concludes that the
+ *	command cannot be bytecompiled effectively, a return code of
+ *	TCL__OUT_LINE_COMPILE is returned.
  *
  * Side effects:
  *	Instructions are added to envPtr to execute the "return" command
@@ -2367,65 +2364,114 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
 				 * command created by Tcl_ParseCommand. */
     CompileEnv *envPtr;		/* Holds resulting instructions. */
 {
-    Tcl_Token *varTokenPtr;
-    int code;
+    /*
+     * General syntax: [return ?-option value ...? ?result?]
+     * An even number of words means an explicit result argument is present.
+     */
+    int level = 1, code = TCL_OK, status = TCL_OK;
+    int numWords = parsePtr->numWords;
+    int explicitResult = (0 == (numWords % 2));
+    int numOptionWords = numWords - 1 - explicitResult;
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *returnOpts = iPtr->defaultReturnOpts;
+    Tcl_Token *wordTokenPtr = parsePtr->tokenPtr
+		+ (parsePtr->tokenPtr->numComponents + 1);
 
-    switch (parsePtr->numWords) {
-	case 1: {
-	    /*
-	     * Simple case:  [return]
-	     * Just push the literal string "".
-	     */
-	    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
-	    break;
+    if (numOptionWords > 0) {
+	/* 
+	 * Scan through the return options.  If any are unknown at compile
+	 * time, there is no value in bytecompiling.  Save the option values
+	 * known in an objv array for merging into a return options dictionary.
+	 */
+	int objc;
+	Tcl_Obj **objv = (Tcl_Obj **)
+		ckalloc(numOptionWords * sizeof(Tcl_Obj *));
+	for (objc = 0; objc < numOptionWords; objc++) {
+	    objv[objc] = Tcl_NewObj();
+	    Tcl_IncrRefCount(objv[objc]);
+	    if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
+		objc++;
+		status = TCL_ERROR;
+		goto cleanup;
+	    }
+	    wordTokenPtr += wordTokenPtr->numComponents + 1;
+	}
+	status = TclMergeReturnOptions(interp, objc, objv,
+		&returnOpts, &code, &level);
+    cleanup:
+	while (--objc >= 0) {
+	    Tcl_DecrRefCount(objv[objc]);
+	}
+	ckfree((char *)objv);
+	if (TCL_ERROR == status) {
+	    /* Something was bogus in the return options.  Clear the
+	     * error message, and report back to the compiler that this
+	     * must be interpreted at runtime. */
+	    Tcl_ResetResult(interp);
+	    return TCL_OUT_LINE_COMPILE;
 	}
-	case 2: {
-	    /*
-	     * More complex cases:
-	     * [return "foo"]
-	     * [return $value]
-	     * [return [otherCmd]]
-	     */
-	    varTokenPtr = parsePtr->tokenPtr
-		+ (parsePtr->tokenPtr->numComponents + 1);
-	    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
-		/*
-		 * [return "foo"] case:  the parse token is a simple word,
-		 * so just push it.
-		 */
-		TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
-			varTokenPtr[1].size), envPtr);
-	    } else {
-		/*
-		 * Parse token is more complex, so compile it; this handles the
-		 * variable reference and nested command cases.  If the
-		 * parse token can be byte-compiled, then this instance of
-		 * "return" will be byte-compiled; otherwise it will be
-		 * out line compiled.
-		 */
-		code = TclCompileTokens(interp, varTokenPtr+1,
-			varTokenPtr->numComponents, envPtr);
-		if (code != TCL_OK) {
-		    return code;
-		}
+    }
+
+    /* All options are known at compile time, so we're going to
+     * bytecompile.   Emit instructions to push the result on
+     * the stack */
+
+    if (explicitResult) {
+	if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+	    /* Explicit result is a simple word, so we can compile quickly to
+	     * a simple push */
+	    TclEmitPush(TclRegisterNewLiteral(envPtr, wordTokenPtr[1].start,
+			wordTokenPtr[1].size), envPtr);
+	} else {
+	    /* More complex tokens get compiled */
+	    status = TclCompileTokens(interp, wordTokenPtr+1,
+		    wordTokenPtr->numComponents, envPtr);
+	    if (TCL_OK != status) {
+		return status;
 	    }
-	    break;
 	}
-	default: {
-	    /*
-	     * Most complex return cases: everything else, including
-	     * [return -code error], etc.
-	     */
-	    return TCL_OUT_LINE_COMPILE;
+    } else {
+	/* No explict result argument, so default result is empty string */
+	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+    }
+
+    /* 
+     * Check for optimization:  When [return] is in a proc, and there's
+     * no enclosing [catch], and the default return options are in effect,
+     * then the INST_DONE instruction is equivalent, and considerably more
+     * efficient.
+     */
+    if (returnOpts == iPtr->defaultReturnOpts) {
+	/* We have default return options... */
+	if (envPtr->procPtr != NULL) {
+	    /* ... and we're in a proc ... */
+	    int index = envPtr->exceptArrayNext - 1;
+	    int enclosingCatch = 0;
+	    while (index >= 0) {
+		ExceptionRange range = envPtr->exceptArrayPtr[index];
+		if ((range.type == CATCH_EXCEPTION_RANGE)
+			&& (range.catchOffset == -1)) {
+		    enclosingCatch = 1;
+		    break;
+		}
+		index--;
+	    }
+	    if (!enclosingCatch) {
+		/* ... and there is no enclosing catch. */
+		TclEmitOpcode(INST_DONE, envPtr);
+		return TCL_OK;
+	    }
 	}
     }
 
     /*
-     * The INST_RETURN opcode triggers the branching out of the
-     * subroutine, and takes the top stack item as the return result
-     * (which is why we pushed the value above).
+     * Could not use the optimization, so we push the return options
+     * dictionary, and emit the INST_RETURN instruction with code
+     * and level as operands.
      */
-    TclEmitOpcode(INST_RETURN, envPtr);
+    TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
+    TclEmitInstInt4(INST_RETURN, code, envPtr);
+    TclEmitInt4(level, envPtr);
     return TCL_OK;
 }
 
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 4946ec2..3f76988 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.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: tclCompile.c,v 1.55 2003/12/24 04:18:19 davygrvy Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.56 2004/01/13 23:15:02 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -269,8 +269,9 @@ InstructionDesc tclInstructionTable[] = {
 	 * stacked objs: stktop is old value, next is new element value, next 
 	 * come (operand-2) indices; pushes the new value.
 	 */
-    {"return",		  1,   -1,          0,   {OPERAND_NONE}},
-	/* return TCL_RETURN code. */
+    {"return",		  1,   -2,          2,   {OPERAND_INT4, OPERAND_UINT4}},
+	/* Compiled [return], code, level are operands; options and result
+	 * are on the stack. */
     {"expon",		  1,   -1,	    0,	 {OPERAND_NONE}},
 	/* Binary exponentiation operator: push (stknext ** stktop) */
     {"listverify",	  1,    0,	    0,   {OPERAND_NONE}},
@@ -781,6 +782,85 @@ TclFreeCompileEnv(envPtr)
 /*
  *----------------------------------------------------------------------
  *
+ * TclWordKnownAtCompileTime --
+ *
+ *	Test whether the value of a token is completely known at compile
+ *	time.
+ *
+ * Results:
+ *	Returns true if the tokenPtr argument points to a word value that
+ *	is completely known at compile time.  Generally, values that are
+ *	known at compile time can be compiled to their values, while values
+ *	that cannot be	known until substitution at runtime must be compiled
+ *	to bytecode instructions that perform that substitution.  For several
+ *	commands, whether or not arguments are known at compile time determine
+ *	whether it is worthwhile to compile at all.
+ *
+ * Side effects:
+ *	When returning true, appends the known value of the word to
+ *	the unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclWordKnownAtCompileTime(tokenPtr, valuePtr)
+    Tcl_Token *tokenPtr;	/* Points to Tcl_Token we should check */
+    Tcl_Obj *valuePtr;		/* If not NULL, points to an unshared Tcl_Obj
+				 * to which we should append the known value
+				 * of the word. */
+{
+    int numComponents = tokenPtr->numComponents;
+    Tcl_Obj *tempPtr = NULL;
+
+    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+	if (valuePtr != NULL) {
+	    Tcl_AppendToObj(valuePtr, tokenPtr->start, tokenPtr->size);
+	}
+	return 1;
+    }
+    if (tokenPtr->type != TCL_TOKEN_WORD) {
+	return 0;
+    }
+    tokenPtr++;
+    if (valuePtr != NULL) {
+	tempPtr = Tcl_NewObj();
+	Tcl_IncrRefCount(tempPtr);
+    }
+    while (numComponents--) {
+	switch (tokenPtr->type) {
+	    case TCL_TOKEN_TEXT:
+		if (tempPtr != NULL) {
+		    Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
+		}
+		continue;
+
+	    case TCL_TOKEN_BS:
+		if (tempPtr != NULL) {
+		    char utfBuf[TCL_UTF_MAX];
+		    int length = 
+			    Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf);
+		    Tcl_AppendToObj(tempPtr, utfBuf, length);
+		}
+		continue;
+	    
+	    default:
+		if (tempPtr != NULL) {
+		    Tcl_DecrRefCount(tempPtr);
+		}
+		return 0;
+	}
+    }
+    if (valuePtr != NULL) {
+	Tcl_AppendObjToObj(valuePtr, tempPtr);
+	Tcl_DecrRefCount(tempPtr);
+    }
+    return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileScript --
  *
  *	Compile a Tcl script in a string.
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 869c7ad..99d719d 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -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: tclCompile.h,v 1.39 2003/11/14 20:44:44 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.40 2004/01/13 23:15:03 dgp Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -828,6 +828,8 @@ EXTERN void		TclVerifyLocalLiteralTable _ANSI_ARGS_((
 #endif
 EXTERN int		TclCompileVariableCmd _ANSI_ARGS_((
 			    Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr));
+EXTERN int		TclWordKnownAtCompileTime _ANSI_ARGS_((
+			    Tcl_Token *tokenPtr, Tcl_Obj *valuePtr));
 
 /*
  *----------------------------------------------------------------
@@ -885,10 +887,11 @@ EXTERN int		TclCompileVariableCmd _ANSI_ARGS_((
     TclUpdateStackReqs(op, 0, envPtr)
 
 /*
- * Macro to emit an integer operand.
- * The ANSI C "prototype" for this macro is:
+ * Macros to emit an integer operand.
+ * The ANSI C "prototype" for these macros are:
  *
  * EXTERN void	TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr));
+ * EXTERN void	TclEmitInt4 _ANSI_ARGS_((int i, CompileEnv *envPtr));
  */
 
 #define TclEmitInt1(i, envPtr) \
@@ -896,6 +899,19 @@ EXTERN int		TclCompileVariableCmd _ANSI_ARGS_((
         TclExpandCodeArray(envPtr); \
     *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))
 
+#define TclEmitInt4(i, envPtr) \
+    if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \
+        TclExpandCodeArray(envPtr); \
+    } \
+    *(envPtr)->codeNext++ = \
+        (unsigned char) ((unsigned int) (i) >> 24); \
+    *(envPtr)->codeNext++ = \
+        (unsigned char) ((unsigned int) (i) >> 16); \
+    *(envPtr)->codeNext++ = \
+        (unsigned char) ((unsigned int) (i) >>  8); \
+    *(envPtr)->codeNext++ = \
+        (unsigned char) ((unsigned int) (i)      )
+
 /*
  * Macros to emit an instruction with signed or unsigned integer operands.
  * Four byte integers are stored in "big-endian" order with the high order
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 61d444b..84e5aee 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.119 2004/01/12 03:23:31 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.120 2004/01/13 23:15:03 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1231,12 +1231,23 @@ TclExecuteByteCode(interp, codePtr)
 
     switch (*pc) {
     case INST_RETURN:
-	if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
-	    Tcl_DecrRefCount(iPtr->returnOpts);
-	    iPtr->returnOpts = iPtr->defaultReturnOpts;
-	    Tcl_IncrRefCount(iPtr->returnOpts);
+	{
+	    int code = TclGetInt4AtPtr(pc+1);
+	    int level = TclGetUInt4AtPtr(pc+5);
+	    Tcl_Obj *returnOpts = POP_OBJECT();
+
+	    DECACHE_STACK_INFO();
+	    Tcl_ResetResult(interp);
+	    result = TclProcessReturn(interp, code, level, returnOpts);
+	    CACHE_STACK_INFO();
+	    Tcl_DecrRefCount(returnOpts);
+	    if (result != TCL_OK) {
+		Tcl_SetObjResult(interp, *tosPtr);
+		cleanup = 1;
+		goto processExceptionReturn;
+	    }
+	    NEXT_INST_F(9, 0, 0);
 	}
-	result = TCL_RETURN;
 
     case INST_DONE:
 	if (tosPtr <= eePtr->stackPtr + initStackTop) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4734cd7..6423e4f 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.139 2003/12/24 04:20:05 davygrvy Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.140 2004/01/13 23:15:03 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1702,6 +1702,10 @@ EXTERN Tcl_Obj *	TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
 						 Tcl_Obj *CONST indexArray[],
 						 Tcl_Obj* valuePtr
 						 ));
+EXTERN int		TclMergeReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
+			    int objc, Tcl_Obj *CONST objv[],
+			    Tcl_Obj **optionsPtrPtr, int *codePtr,
+			    int *levelPtr));
 EXTERN int              TclParseBackslash _ANSI_ARGS_((CONST char *src,
                             int numBytes, int *readPtr, char *dst));
 EXTERN int		TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes,
@@ -1710,6 +1714,8 @@ EXTERN int		TclParseInteger _ANSI_ARGS_((CONST char *string,
 			    int numBytes));
 EXTERN int		TclParseWhiteSpace _ANSI_ARGS_((CONST char *src,
 			    int numBytes, Tcl_Parse *parsePtr, char *typePtr));
+EXTERN int		TclProcessReturn _ANSI_ARGS_((Tcl_Interp *interp,
+			    int code, int level, Tcl_Obj *returnOpts));
 EXTERN int		TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
 			    int mode));
 EXTERN int              TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr,