Attachment "return.patch" to
ticket [876451ffff]
added by
dgp
2004-01-14 05:47:41.
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.98
diff -u -r1.98 tclCmdMZ.c
--- generic/tclCmdMZ.c 24 Dec 2003 04:18:18 -0000 1.98
+++ generic/tclCmdMZ.c 13 Jan 2004 22:20:33 -0000
@@ -844,29 +844,138 @@
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 @@
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 @@
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 @@
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 @@
*/
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;
- }
- }
+ /*
+ * 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 (codePtr != NULL) {
+ *codePtr = 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 {
- code = TCL_RETURN;
+ *optionsPtrPtr = returnOpts;
}
-
- if (objc == 1) {
- Tcl_SetObjResult(interp, objv[0]);
- }
- return code;
-
+ return TCL_OK;
}
/*
Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.52
diff -u -r1.52 tclCompCmds.c
--- generic/tclCompCmds.c 24 Dec 2003 04:18:19 -0000 1.52
+++ generic/tclCompCmds.c 13 Jan 2004 22:20:34 -0000
@@ -2346,12 +2346,9 @@
*
* 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 @@
* 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).
- */
- TclEmitOpcode(INST_RETURN, envPtr);
+ * Could not use the optimization, so we push the return options
+ * dictionary, and emit the INST_RETURN instruction with code
+ * and level as operands.
+ */
+ TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
+ TclEmitInstInt4(INST_RETURN, code, envPtr);
+ TclEmitInt4(level, envPtr);
return TCL_OK;
}
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.55
diff -u -r1.55 tclCompile.c
--- generic/tclCompile.c 24 Dec 2003 04:18:19 -0000 1.55
+++ generic/tclCompile.c 13 Jan 2004 22:20:34 -0000
@@ -269,8 +269,9 @@
* 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 @@
/*
*----------------------------------------------------------------------
*
+ * 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.
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.39
diff -u -r1.39 tclCompile.h
--- generic/tclCompile.h 14 Nov 2003 20:44:44 -0000 1.39
+++ generic/tclCompile.h 13 Jan 2004 22:20:34 -0000
@@ -828,6 +828,8 @@
#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 @@
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 @@
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
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.119
diff -u -r1.119 tclExecute.c
--- generic/tclExecute.c 12 Jan 2004 03:23:31 -0000 1.119
+++ generic/tclExecute.c 13 Jan 2004 22:20:35 -0000
@@ -1231,12 +1231,23 @@
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) {
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.139
diff -u -r1.139 tclInt.h
--- generic/tclInt.h 24 Dec 2003 04:20:05 -0000 1.139
+++ generic/tclInt.h 13 Jan 2004 22:20:35 -0000
@@ -1702,6 +1702,10 @@
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 @@
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,
