summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c42
-rw-r--r--generic/tclCmdAH.c69
-rw-r--r--generic/tclCmdMZ.c218
-rw-r--r--generic/tclCompCmds.c11
-rw-r--r--generic/tclExecute.c13
-rw-r--r--generic/tclInt.h23
-rw-r--r--generic/tclProc.c52
-rw-r--r--generic/tclResult.c9
8 files changed, 323 insertions, 114 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index bd8efdc..5551c45 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.80 2003/05/05 16:48:54 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.81 2003/05/05 20:54:38 dgp Exp $
*/
#include "tclInt.h"
@@ -337,9 +337,27 @@ Tcl_CreateInterp()
iPtr->framePtr = NULL;
iPtr->varFramePtr = NULL;
iPtr->activeVarTracePtr = NULL;
- iPtr->returnCode = TCL_OK;
- iPtr->errorInfo = NULL;
- iPtr->errorCode = NULL;
+
+ iPtr->returnCodeKey = Tcl_NewStringObj("-code",-1);
+ Tcl_IncrRefCount(iPtr->returnCodeKey);
+ iPtr->returnErrorcodeKey = Tcl_NewStringObj("-errorcode",-1);
+ Tcl_IncrRefCount(iPtr->returnErrorcodeKey);
+ iPtr->returnErrorinfoKey = Tcl_NewStringObj("-errorinfo",-1);
+ Tcl_IncrRefCount(iPtr->returnErrorinfoKey);
+ iPtr->returnErrorlineKey = Tcl_NewStringObj("-errorline",-1);
+ Tcl_IncrRefCount(iPtr->returnErrorlineKey);
+ iPtr->returnLevelKey = Tcl_NewStringObj("-level",-1);
+ 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;
+ Tcl_IncrRefCount(iPtr->returnOpts);
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
@@ -1062,14 +1080,14 @@ DeleteInterpProc(interp)
interp->result = NULL;
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
- if (iPtr->errorInfo != NULL) {
- ckfree(iPtr->errorInfo);
- iPtr->errorInfo = NULL;
- }
- if (iPtr->errorCode != NULL) {
- ckfree(iPtr->errorCode);
- iPtr->errorCode = NULL;
- }
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ Tcl_DecrRefCount(iPtr->defaultReturnOpts);
+ Tcl_DecrRefCount(iPtr->returnCodeKey);
+ Tcl_DecrRefCount(iPtr->returnErrorcodeKey);
+ Tcl_DecrRefCount(iPtr->returnErrorinfoKey);
+ Tcl_DecrRefCount(iPtr->returnErrorlineKey);
+ Tcl_DecrRefCount(iPtr->returnLevelKey);
+ Tcl_DecrRefCount(iPtr->returnOptionsKey);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 0536dd2..3731974 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.31 2003/04/16 23:33:43 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.32 2003/05/05 20:54:38 dgp Exp $
*/
#include "tclInt.h"
@@ -234,10 +234,12 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
+ Tcl_Obj *optionVarNamePtr = NULL;
int result;
- if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
+ if ((objc < 2) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "script ?resultVarName? ?optionVarName?");
return TCL_ERROR;
}
@@ -247,21 +249,74 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
* stack rendering objv invalid.
*/
- if (objc == 3) {
+ if (objc >= 3) {
varNamePtr = objv[2];
}
+ if (objc == 4) {
+ optionVarNamePtr = objv[3];
+ }
result = Tcl_EvalObjEx(interp, objv[1], 0);
- if (objc == 3) {
- if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
- Tcl_GetObjResult(interp), 0) == NULL) {
+ if (objc >= 3) {
+ if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_GetObjResult(interp), 0)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"couldn't save command result in variable", -1);
return TCL_ERROR;
}
}
+ if (objc == 4) {
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *options = Tcl_DuplicateObj(iPtr->returnOpts);
+ Tcl_Obj *value = NULL;
+
+ if (result != TCL_RETURN) {
+ Tcl_DictObjPut(NULL, options,
+ iPtr->returnCodeKey, Tcl_NewIntObj(result));
+ Tcl_DictObjPut(NULL, options,
+ iPtr->returnLevelKey, Tcl_NewIntObj(0));
+ }
+
+ if (iPtr->flags & ERR_IN_PROGRESS) {
+ value = NULL;
+ Tcl_DictObjGet(NULL, options, iPtr->returnErrorinfoKey, &value);
+ if (NULL == value) {
+ Tcl_DictObjPut(NULL, options, iPtr->returnErrorinfoKey,
+ Tcl_ObjGetVar2(interp, iPtr->execEnvPtr->errorInfo,
+ NULL, TCL_GLOBAL_ONLY));
+ }
+ }
+
+ if (iPtr->flags & ERROR_CODE_SET) {
+ value = NULL;
+ Tcl_DictObjGet(NULL, options, iPtr->returnErrorcodeKey, &value);
+ if (NULL == value) {
+ Tcl_DictObjPut(NULL, options, iPtr->returnErrorcodeKey,
+ Tcl_ObjGetVar2(interp, iPtr->execEnvPtr->errorCode,
+ NULL, TCL_GLOBAL_ONLY));
+ }
+ }
+
+ if (result == TCL_ERROR) {
+ value = NULL;
+ Tcl_DictObjGet(NULL, options, iPtr->returnErrorlineKey, &value);
+ if (NULL == value) {
+ Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey,
+ Tcl_NewIntObj(iPtr->errorLine));
+ }
+ }
+
+ if (NULL ==
+ Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) {
+ Tcl_DecrRefCount(options);
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "couldn't save return options in variable", -1);
+ return TCL_ERROR;
+ }
+ }
/*
* Set the interpreter's object result to an integer object holding the
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 21b439c..3e9d8d0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -14,7 +14,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.86 2003/04/11 20:50:47 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.87 2003/05/05 20:54:38 dgp Exp $
*/
#include "tclInt.h"
@@ -934,74 +934,150 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- int optionLen, argLen, code, result;
-
- if (iPtr->errorInfo != NULL) {
- ckfree(iPtr->errorInfo);
- iPtr->errorInfo = NULL;
+ int code, level;
+ Tcl_Obj *valuePtr;
+
+ /* Start with the default options */
+ if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ iPtr->returnOpts = iPtr->defaultReturnOpts;
+ Tcl_IncrRefCount(iPtr->returnOpts);
}
- if (iPtr->errorCode != NULL) {
- ckfree(iPtr->errorCode);
- iPtr->errorCode = NULL;
+
+ 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);
}
- code = TCL_OK;
- for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
- char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
- char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
-
- if (strcmp(option, "-code") == 0) {
- register int c = arg[0];
- if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
- code = TCL_OK;
- } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
- code = TCL_ERROR;
- } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
- code = TCL_RETURN;
- } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
- code = TCL_BREAK;
- } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
- code = TCL_CONTINUE;
- } else {
- result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
- &code);
- if (result != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad completion code \"",
- Tcl_GetString(objv[1]),
- "\": must be ok, error, return, break, ",
- "continue, or an integer", (char *) NULL);
- return result;
- }
+ 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)) {
+ Tcl_DictSearch search;
+ int done = 0;
+ Tcl_Obj *keyPtr;
+ Tcl_Obj *dict = objv[1];
+
+ nestedOptions:
+ 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_GetString(objv[1]), "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ while (!done) {
+ Tcl_DictObjPut(NULL, iPtr->returnOpts, keyPtr, valuePtr);
+ Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
+ }
+
+ valuePtr = NULL;
+ Tcl_DictObjGet(NULL, iPtr->returnOpts,
+ iPtr->returnOptionsKey, &valuePtr);
+ if (valuePtr != NULL) {
+ dict = valuePtr;
+ Tcl_DictObjRemove(NULL, iPtr->returnOpts,
+ iPtr->returnOptionsKey);
+ goto nestedOptions;
}
- } else if (strcmp(option, "-errorinfo") == 0) {
- iPtr->errorInfo =
- (char *) ckalloc((unsigned) (strlen(arg) + 1));
- strcpy(iPtr->errorInfo, arg);
- } else if (strcmp(option, "-errorcode") == 0) {
- iPtr->errorCode =
- (char *) ckalloc((unsigned) (strlen(arg) + 1));
- strcpy(iPtr->errorCode, arg);
+
} else {
+ Tcl_DictObjPut(NULL, iPtr->returnOpts, objv[0], objv[1]);
+ }
+ }
+
+ /* Check for bogus -code value */
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
+ if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code)) {
+ static CONST char *returnCodes[] = {
+ "ok", "error", "return", "break", "continue"
+ };
+
+ 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 option \"", option,
- "\": must be -code, -errorcode, or -errorinfo",
- (char *) NULL);
+ "bad completion code \"",
+ Tcl_GetString(valuePtr),
+ "\": must be ok, error, return, break, ",
+ "continue, or an integer", (char *) NULL);
return TCL_ERROR;
}
+ /* Have a legal string value for a return code; convert to integer */
+ Tcl_DictObjPut(NULL, iPtr->returnOpts,
+ iPtr->returnCodeKey, Tcl_NewIntObj(code));
+ }
+
+ /* Check for bogus -level value */
+ Tcl_DictObjGet(NULL, iPtr->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 \"",
+ Tcl_GetString(valuePtr), "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Convert [return -code return -level X] to
+ * [return -code ok -level X+1]
+ */
+ if (code == TCL_RETURN) {
+ level++;
+ Tcl_DictObjPut(NULL, iPtr->returnOpts,
+ iPtr->returnLevelKey, Tcl_NewIntObj(level));
+ Tcl_DictObjPut(NULL, iPtr->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;
}
-
- if (objc == 1) {
- /*
- * Set the interpreter's object result. An inline version of
- * Tcl_SetObjResult.
- */
+ if (objc == 1) {
Tcl_SetObjResult(interp, objv[0]);
}
- iPtr->returnCode = code;
- return TCL_RETURN;
+ return code;
+
}
/*
@@ -3851,7 +3927,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
* information. */
{
Interp *iPtr = (Interp *) interp;
- int stateCode;
+ Tcl_Obj *stateReturnOpts;
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
@@ -3877,7 +3953,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
/*
* Execute the command. Save the interp's result used for the
- * command, including the value of iPtr->returnCode which may be
+ * command, including the value of iPtr->returnOpts which may be
* modified when Tcl_Eval is invoked. We discard any object
* result the command returns.
*
@@ -3887,7 +3963,8 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
*/
Tcl_SaveResult(interp, &state);
- stateCode = iPtr->returnCode;
+ stateReturnOpts = iPtr->returnOpts;
+ Tcl_IncrRefCount(stateReturnOpts);
if (flags & TCL_TRACE_DESTROYED) {
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
}
@@ -3899,7 +3976,12 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
}
Tcl_RestoreResult(interp, &state);
- iPtr->returnCode = stateCode;
+ if (iPtr->returnOpts != stateReturnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ iPtr->returnOpts = stateReturnOpts;
+ Tcl_IncrRefCount(iPtr->returnOpts);
+ }
+ Tcl_DecrRefCount(stateReturnOpts);
Tcl_DStringFree(&cmd);
}
@@ -4302,7 +4384,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
*/
if (call) {
Tcl_SavedResult state;
- int stateCode;
+ Tcl_Obj *stateReturnOpts;
Tcl_DString cmd;
Tcl_DString sub;
int i;
@@ -4351,13 +4433,14 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
/*
* Execute the command. Save the interp's result used for
- * the command, including the value of iPtr->returnCode which
+ * the command, including the value of iPtr->returnOpts which
* may be modified when Tcl_Eval is invoked. We discard any
* object result the command returns.
*/
Tcl_SaveResult(interp, &state);
- stateCode = iPtr->returnCode;
+ stateReturnOpts = iPtr->returnOpts;
+ Tcl_IncrRefCount(stateReturnOpts);
tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
@@ -4377,10 +4460,15 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
if (traceCode == TCL_OK) {
/* Restore result if trace execution was successful */
Tcl_RestoreResult(interp, &state);
- iPtr->returnCode = stateCode;
+ if (iPtr->returnOpts != stateReturnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ iPtr->returnOpts = stateReturnOpts;
+ Tcl_IncrRefCount(iPtr->returnOpts);
+ }
} else {
Tcl_DiscardResult(&state);
}
+ Tcl_DecrRefCount(stateReturnOpts);
Tcl_DStringFree(&cmd);
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 709359d..139463f 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.48 2003/05/01 19:57:47 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.49 2003/05/05 20:54:38 dgp Exp $
*/
#include "tclInt.h"
@@ -246,11 +246,12 @@ TclCompileCatchCmd(interp, parsePtr, envPtr)
int code;
int savedStackDepth = envPtr->currStackDepth;
+ /*
+ * If syntax does not match what we expect for [catch], do not
+ * compile. Let runtime checks determine if syntax has changed.
+ */
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"catch command ?varName?\"", -1);
- return TCL_ERROR;
+ return TCL_OUT_LINE_COMPILE;
}
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 3d324a5..0697677 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.100 2003/04/28 12:34:25 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.101 2003/05/05 20:54:39 dgp Exp $
*/
#include "tclInt.h"
@@ -975,6 +975,11 @@ TclCompEvalObj(interp, objPtr)
*/
codePtr->refCount++;
+ if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ iPtr->returnOpts = iPtr->defaultReturnOpts;
+ Tcl_IncrRefCount(iPtr->returnOpts);
+ }
iPtr->numLevels++;
result = TclExecuteByteCode(interp, codePtr);
iPtr->numLevels--;
@@ -1196,7 +1201,11 @@ TclExecuteByteCode(interp, codePtr)
#endif
switch (*pc) {
case INST_RETURN:
- iPtr->returnCode = TCL_OK;
+ if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ iPtr->returnOpts = iPtr->defaultReturnOpts;
+ Tcl_IncrRefCount(iPtr->returnOpts);
+ }
result = TCL_RETURN;
case INST_DONE:
if (stackTop <= initStackTop) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 70b8106..c440202 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.126 2003/04/28 12:34:27 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.127 2003/05/05 20:54:40 dgp Exp $
*/
#ifndef _TCLINT
@@ -1206,12 +1206,9 @@ typedef struct Interp {
ActiveVarTrace *activeVarTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
- int returnCode; /* Completion code to return if current
- * procedure exits with TCL_RETURN code. */
- char *errorInfo; /* Value to store in errorInfo if returnCode
- * is TCL_ERROR. Malloc'ed, may be NULL */
- char *errorCode; /* Value to store in errorCode if returnCode
- * is TCL_ERROR. Malloc'ed, may be NULL */
+ int unused2; /* No longer used (was returnCode) */
+ char *unused3; /* No longer used (was errorInfo) */
+ char *unused4; /* No longer used (was errorCode) */
/*
* Information used by Tcl_AppendResult to keep track of partial
@@ -1305,6 +1302,18 @@ typedef struct Interp {
int tracesForbiddingInline; /* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation */
+
+ /* 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" */
+ Tcl_Obj *returnErrorlineKey; /* holds "-errorline" */
+ Tcl_Obj *returnLevelKey; /* holds "-level" */
+ Tcl_Obj *returnOptionsKey; /* holds "-options" */
+
/*
* Statistical information about the bytecode compiler and interpreter's
* operation.
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 4e3d4b8..9f8d1e4 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.44 2002/12/11 21:29:52 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.45 2003/05/05 20:54:40 dgp Exp $
*/
#include "tclInt.h"
@@ -1077,7 +1077,6 @@ TclObjInterpProc(clientData, interp, objc, objv)
}
#endif /*TCL_COMPILE_DEBUG*/
- iPtr->returnCode = TCL_OK;
procPtr->refCount++;
result = TclCompEvalObj(interp, procPtr->bodyPtr);
procPtr->refCount--;
@@ -1409,8 +1408,8 @@ TclProcCleanupProc(procPtr)
* TclUpdateReturnInfo --
*
* This procedure is called when procedures return, and at other
- * points where the TCL_RETURN code is used. It examines fields
- * such as iPtr->returnCode and iPtr->errorCode and modifies
+ * points where the TCL_RETURN code is used. It examines values
+ * stored in the iPtr->returnOpts dictionary and modifies
* the real return status accordingly.
*
* Results:
@@ -1428,21 +1427,46 @@ TclUpdateReturnInfo(iPtr)
Interp *iPtr; /* Interpreter for which TCL_RETURN
* exception is being processed. */
{
- int code;
+ int level, code = TCL_RETURN;
char *errorCode;
+ Tcl_Obj *valuePtr;
- code = iPtr->returnCode;
- iPtr->returnCode = TCL_OK;
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
+ Tcl_GetIntFromObj(NULL, valuePtr, &level);
+ level--;
+ if (level < 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) {
+ /* Now we've reached the level to return the requested -code */
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
+ Tcl_GetIntFromObj(NULL, valuePtr, &code);
+ }
if (code == TCL_ERROR) {
- errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
- Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
- NULL, Tcl_NewStringObj(errorCode, -1),
- TCL_GLOBAL_ONLY);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts,
+ iPtr->returnErrorcodeKey, &valuePtr);
+ if (valuePtr == NULL) {
+ Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
+ NULL, Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY);
+ } else {
+ Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
+ NULL, valuePtr, TCL_GLOBAL_ONLY);
+ }
iPtr->flags |= ERROR_CODE_SET;
- if (iPtr->errorInfo != NULL) {
+
+ Tcl_DictObjGet(NULL, iPtr->returnOpts,
+ iPtr->returnErrorinfoKey, &valuePtr);
+ if (valuePtr != NULL) {
Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
- NULL, Tcl_NewStringObj(iPtr->errorInfo, -1),
- TCL_GLOBAL_ONLY);
+ NULL, valuePtr, TCL_GLOBAL_ONLY);
iPtr->flags |= ERR_IN_PROGRESS;
}
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 367ca80..4eb3c69 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -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: tclResult.c,v 1.5 2002/01/25 20:40:55 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.6 2003/05/05 20:54:40 dgp Exp $
*/
#include "tclInt.h"
@@ -1046,7 +1046,12 @@ TclTransferResult(sourceInterp, result, targetInterp)
((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
}
- ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
+ /* This may need examination for safety */
+ Tcl_DecrRefCount( ((Interp *) targetInterp)->returnOpts );
+ ((Interp *) targetInterp)->returnOpts =
+ ((Interp *) sourceInterp)->returnOpts;
+ Tcl_IncrRefCount( ((Interp *) targetInterp)->returnOpts );
+
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}
generated by cgit v0.12 at 2024-11-10 12:10:44 (GMT)