diff options
| -rw-r--r-- | ChangeLog | 27 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 218 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 160 | ||||
| -rw-r--r-- | generic/tclCompile.c | 86 | ||||
| -rw-r--r-- | generic/tclCompile.h | 22 | ||||
| -rw-r--r-- | generic/tclExecute.c | 23 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 |
7 files changed, 410 insertions, 134 deletions
@@ -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, |