summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c13
-rw-r--r--generic/tclCmdAH.c34
-rw-r--r--generic/tclCmdMZ.c54
-rw-r--r--generic/tclCompCmds.c103
-rw-r--r--generic/tclExecute.c7
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclProc.c33
7 files changed, 108 insertions, 142 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 69a2453..84b934d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.127 2004/10/15 15:42:52 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.128 2004/10/18 21:15:34 dgp Exp $
*/
#include "tclInt.h"
@@ -233,13 +233,7 @@ Tcl_CreateInterp()
Tcl_IncrRefCount(iPtr->returnLevelKey);
iPtr->returnOptionsKey = Tcl_NewStringObj("-options",-1);
Tcl_IncrRefCount(iPtr->returnOptionsKey);
- iPtr->defaultReturnOpts = Tcl_NewDictObj();
- Tcl_DictObjPut(NULL, iPtr->defaultReturnOpts,
- iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK));
- Tcl_DictObjPut(NULL, iPtr->defaultReturnOpts,
- iPtr->returnLevelKey, Tcl_NewIntObj(1));
- Tcl_IncrRefCount(iPtr->defaultReturnOpts);
- iPtr->returnOpts = iPtr->defaultReturnOpts;
+ iPtr->returnOpts = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->returnOpts);
iPtr->errorInfo = NULL;
iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1);
@@ -247,6 +241,8 @@ Tcl_CreateInterp()
iPtr->errorCode = NULL;
iPtr->ecVar = Tcl_NewStringObj("errorCode", -1);
Tcl_IncrRefCount(iPtr->ecVar);
+ iPtr->returnLevel = 0;
+ iPtr->returnCode = TCL_OK;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
@@ -994,7 +990,6 @@ DeleteInterpProc(interp)
iPtr->errorInfo = NULL;
}
Tcl_DecrRefCount(iPtr->returnOpts);
- Tcl_DecrRefCount(iPtr->defaultReturnOpts);
Tcl_DecrRefCount(iPtr->returnCodeKey);
Tcl_DecrRefCount(iPtr->returnErrorcodeKey);
Tcl_DecrRefCount(iPtr->returnErrorinfoKey);
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 960b039..8d44139 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.54 2004/10/15 04:01:28 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.55 2004/10/18 21:15:35 dgp Exp $
*/
#include "tclInt.h"
@@ -271,9 +271,13 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
if (objc == 4) {
Interp *iPtr = (Interp *) interp;
Tcl_Obj *options = Tcl_DuplicateObj(iPtr->returnOpts);
- Tcl_Obj *value = NULL;
- if (result != TCL_RETURN) {
+ if (result == TCL_RETURN) {
+ Tcl_DictObjPut(NULL, options,
+ iPtr->returnCodeKey, Tcl_NewIntObj(iPtr->returnCode));
+ Tcl_DictObjPut(NULL, options,
+ iPtr->returnLevelKey, Tcl_NewIntObj(iPtr->returnLevel));
+ } else {
Tcl_DictObjPut(NULL, options,
iPtr->returnCodeKey, Tcl_NewIntObj(result));
Tcl_DictObjPut(NULL, options,
@@ -285,26 +289,12 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
* When result was an error, fill in any missing values
* for -errorinfo, -errorcode, and -errorline
*/
-
- value = NULL;
- Tcl_DictObjGet(NULL, options, iPtr->returnErrorinfoKey, &value);
- if (NULL == value) {
- Tcl_DictObjPut(NULL, options, iPtr->returnErrorinfoKey,
- iPtr->errorInfo);
- }
-
- value = NULL;
- Tcl_DictObjGet(NULL, options, iPtr->returnErrorcodeKey, &value);
- if (NULL == value) {
- Tcl_DictObjPut(NULL, options, iPtr->returnErrorcodeKey,
- iPtr->errorCode);
- }
- value = NULL;
- Tcl_DictObjGet(NULL, options, iPtr->returnErrorlineKey, &value);
- if (NULL == value) {
- Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey,
+ Tcl_DictObjPut(NULL, options,
+ iPtr->returnErrorinfoKey, iPtr->errorInfo);
+ Tcl_DictObjPut(NULL, options,
+ iPtr->returnErrorcodeKey, iPtr->errorCode);
+ Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey,
Tcl_NewIntObj(iPtr->errorLine));
- }
}
if (NULL ==
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 3fba9fc..9a8b617 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.113 2004/10/15 21:02:35 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.114 2004/10/18 21:15:35 dgp Exp $
*/
#include "tclInt.h"
@@ -930,6 +930,8 @@ TclProcessReturn(interp, code, level, returnOpts)
}
}
if (level != 0) {
+ iPtr->returnLevel = level;
+ iPtr->returnCode = code;
return TCL_RETURN;
}
return code;
@@ -968,16 +970,17 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
* -level value should be written */
{
Interp *iPtr = (Interp *) interp;
- int code, level, size;
+ int code=TCL_OK;
+ int level = 1;
Tcl_Obj *valuePtr;
- Tcl_Obj *returnOpts = Tcl_DuplicateObj(iPtr->defaultReturnOpts);
+ 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);
+ CONST char *compare = Tcl_GetStringFromObj(
+ iPtr->returnOptionsKey, &compareLen);
if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
Tcl_DictSearch search;
@@ -1016,7 +1019,8 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
/* Check for bogus -code value */
Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr);
- if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code)) {
+ if ((valuePtr != NULL)
+ && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
static CONST char *returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
@@ -1031,20 +1035,22 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
"continue, or an integer", (char *) NULL);
goto error;
}
- /* Have a legal string value for a return code; convert to integer */
- Tcl_DictObjPut(NULL, returnOpts,
- iPtr->returnCodeKey, Tcl_NewIntObj(code));
+ Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey);
}
/* Check for bogus -level value */
Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr);
- 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 \"",
+ 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;
+ goto error;
+ }
+ Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey);
}
/*
@@ -1053,10 +1059,7 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
*/
if (code == TCL_RETURN) {
level++;
- Tcl_DictObjPut(NULL, returnOpts,
- iPtr->returnLevelKey, Tcl_NewIntObj(level));
- Tcl_DictObjPut(NULL, returnOpts,
- iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK));
+ code = TCL_OK;
}
if (codePtr != NULL) {
@@ -1068,19 +1071,6 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
if (optionsPtrPtr == NULL) {
/* Not passing back the options (?!), so clean them up */
Tcl_DecrRefCount(returnOpts);
- return TCL_OK;
- }
-
- /*
- * 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);
- *optionsPtrPtr = iPtr->defaultReturnOpts;
} else {
*optionsPtrPtr = returnOpts;
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 99a98c0..92381a9 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.58 2004/09/26 16:36:04 msofer Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.59 2004/10/18 21:15:37 dgp Exp $
*/
#include "tclInt.h"
@@ -2258,58 +2258,66 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
* 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 level, code, 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_Obj *returnOpts;
Tcl_Token *wordTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
+#define NUM_STATIC_OBJS 20
+ int objc;
+ Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
- 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]);
+ if (numOptionWords > NUM_STATIC_OBJS) {
+ objv = (Tcl_Obj **) ckalloc(numOptionWords * sizeof(Tcl_Obj *));
+ } else {
+ objv = staticObjArray;
+ }
+
+ /*
+ * 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.
+ */
+
+ 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]);
+ }
+ if (numOptionWords > NUM_STATIC_OBJS) {
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;
- }
+ }
+ 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;
}
- /* All options are known at compile time, so we're going to
- * bytecompile. Emit instructions to push the result on
- * the stack */
+ /*
+ * 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 */
+ /* Simple word: compile quickly to a simple push */
TclEmitPush(TclRegisterNewLiteral(envPtr, wordTokenPtr[1].start,
wordTokenPtr[1].size), envPtr);
} else {
@@ -2322,13 +2330,12 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
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) {
+ /*
+ * Check for optimization: When [return] is in a proc, and there's
+ * no enclosing [catch], and there are no return options, then the
+ * INST_DONE instruction is equivalent, and may be more efficient.
+ */
+ if (numOptionWords == 0) {
/* We have default return options... */
if (envPtr->procPtr != NULL) {
/* ... and we're in a proc ... */
@@ -2345,6 +2352,7 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
}
if (!enclosingCatch) {
/* ... and there is no enclosing catch. */
+ Tcl_DecrRefCount(returnOpts);
TclEmitOpcode(INST_DONE, envPtr);
return TCL_OK;
}
@@ -2356,6 +2364,7 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
* 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);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b59389b..4268a3e 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.157 2004/10/15 04:01:29 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.158 2004/10/18 21:15:38 dgp Exp $
*/
#ifdef STDC_HEADERS
@@ -983,11 +983,6 @@ TclCompEvalObj(interp, objPtr)
*/
codePtr->refCount++;
- if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
- Tcl_DecrRefCount(iPtr->returnOpts);
- iPtr->returnOpts = iPtr->defaultReturnOpts;
- Tcl_IncrRefCount(iPtr->returnOpts);
- }
result = TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;
if (codePtr->refCount <= 0) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f513b19..3ffaacc 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.181 2004/10/15 04:01:31 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.182 2004/10/18 21:15:41 dgp Exp $
*/
#ifndef _TCLINT
@@ -1222,7 +1222,7 @@ typedef struct Interp {
ActiveVarTrace *activeVarTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
- int unused2; /* No longer used (was returnCode) */
+ int returnCode; /* [return -code] parameter */
char *unused3; /* No longer used (was errorInfo) */
char *unused4; /* No longer used (was errorCode) */
@@ -1322,7 +1322,6 @@ typedef struct Interp {
/* Fields used to manage extensible return options (TIP 90) */
Tcl_Obj *returnOpts; /* A dictionary holding the options to the
* last [return] command */
- Tcl_Obj *defaultReturnOpts; /* Default [return] options */
Tcl_Obj *returnCodeKey; /* holds "-code" */
Tcl_Obj *returnErrorcodeKey; /* holds "-errorcode" */
Tcl_Obj *returnErrorinfoKey; /* holds "-errorinfo" */
@@ -1334,6 +1333,7 @@ typedef struct Interp {
Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable */
Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj) */
Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable */
+ int returnLevel; /* [return -level] parameter */
/*
* Resource limiting framework support (TIP#143).
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 3756024..9ce8706 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.61 2004/10/15 21:02:36 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.62 2004/10/18 21:15:42 dgp Exp $
*/
#include "tclInt.h"
@@ -1430,16 +1430,15 @@ TclProcCleanupProc(procPtr)
* TclUpdateReturnInfo --
*
* This procedure is called when procedures return, and at other
- * points where the TCL_RETURN code is used. It examines values
- * stored in the iPtr->returnOpts dictionary and modifies
- * the real return status accordingly.
+ * points where the TCL_RETURN code is used. It examines the
+ * returnLevel and returnCode to determine the real return status.
*
* Results:
* The return value is the true completion code to use for
- * the procedure, instead of TCL_RETURN.
+ * the procedure or script, instead of TCL_RETURN.
*
* Side effects:
- * The errorInfo and errorCode fields may get set.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1449,27 +1448,15 @@ TclUpdateReturnInfo(iPtr)
Interp *iPtr; /* Interpreter for which TCL_RETURN
* exception is being processed. */
{
- int level, code = TCL_RETURN;
- Tcl_Obj *valuePtr;
+ int code = TCL_RETURN;
- Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
- Tcl_GetIntFromObj(NULL, valuePtr, &level);
- level--;
- if (level < 0) {
+ iPtr->returnLevel--;
+ if (iPtr->returnLevel < 0) {
Tcl_Panic("TclUpdateReturnInfo: negative return level");
}
- if (Tcl_IsShared(iPtr->returnOpts)) {
- Tcl_DecrRefCount(iPtr->returnOpts);
- iPtr->returnOpts = Tcl_DuplicateObj(iPtr->returnOpts);
- Tcl_IncrRefCount(iPtr->returnOpts);
- }
- Tcl_DictObjPut(NULL, iPtr->returnOpts,
- iPtr->returnLevelKey, Tcl_NewIntObj(level));
-
- if (level == 0) {
+ if (iPtr->returnLevel == 0) {
/* Now we've reached the level to return the requested -code */
- Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
- Tcl_GetIntFromObj(NULL, valuePtr, &code);
+ return iPtr->returnCode;
}
return code;
}