summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-10-21 15:19:43 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-10-21 15:19:43 (GMT)
commit302b35c0ac3658a27a30f795d3229e8a43eb5379 (patch)
tree876886b2a00fbe951800502983cfa1c7e9edc97b
parent0e16d1cc7dd629f7bb9a3d1af174b072e9c8ae6c (diff)
downloadtcl-302b35c0ac3658a27a30f795d3229e8a43eb5379.zip
tcl-302b35c0ac3658a27a30f795d3229e8a43eb5379.tar.gz
tcl-302b35c0ac3658a27a30f795d3229e8a43eb5379.tar.bz2
* generic/tclCmdAH.c (Tcl_CatchObjCmd, Tcl_ErrorObjCmd):
Updated to call the new TclGet/SetReturnOptions routines to do much of their work. * generic/tclInt.h (TclGetReturnOptions,TclSetReturnOptions): * generic/tclResult.c (TclGetReturnOptions,TclSetReturnOptions): New utility routines to get/set the return options of an interp. Intent is that these routines will be converted to public routines after TIP approval. * generic/tclCmdMZ.c (TclProcessReturn,TclMergeReturnOptions): * generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions): Move internal utility routines from tclCmdMZ.c to tclResult.c. * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp): * generic/tclResult.c (TclTransferResult): Rework so that iPtr->returnOpts can be NULL when there are no special options. * generic/tclResult.c (TclRestoreInterpState): Plug potential memory leak.
-rw-r--r--ChangeLog23
-rw-r--r--generic/tclBasic.c9
-rw-r--r--generic/tclCmdAH.c59
-rw-r--r--generic/tclCmdMZ.c218
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclResult.c360
6 files changed, 395 insertions, 280 deletions
diff --git a/ChangeLog b/ChangeLog
index 6328979..f843ea2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,26 @@
+2004-10-21 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclCmdAH.c (Tcl_CatchObjCmd, Tcl_ErrorObjCmd):
+ Updated to call the new TclGet/SetReturnOptions routines to do
+ much of their work.
+
+ * generic/tclInt.h (TclGetReturnOptions,TclSetReturnOptions):
+ * generic/tclResult.c (TclGetReturnOptions,TclSetReturnOptions):
+ New utility routines to get/set the return options of an interp.
+ Intent is that these routines will be converted to public routines
+ after TIP approval.
+
+ * generic/tclCmdMZ.c (TclProcessReturn,TclMergeReturnOptions):
+ * generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions):
+ Move internal utility routines from tclCmdMZ.c to tclResult.c.
+
+ * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp):
+ * generic/tclResult.c (TclTransferResult): Rework so that
+ iPtr->returnOpts can be NULL when there are no special options.
+
+ * generic/tclResult.c (TclRestoreInterpState): Plug potential
+ memory leak.
+
2004-10-21 Kevin B. Kenny <kennykb@acm.org>
* generic/tclBasic.c: Various changes to [clock format] that,
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1a370bc..7451b69 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.130 2004/10/21 03:53:04 kennykb Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.131 2004/10/21 15:19:46 dgp Exp $
*/
#include "tclInt.h"
@@ -233,8 +233,7 @@ Tcl_CreateInterp()
Tcl_IncrRefCount(iPtr->returnLevelKey);
iPtr->returnOptionsKey = Tcl_NewStringObj("-options",-1);
Tcl_IncrRefCount(iPtr->returnOptionsKey);
- iPtr->returnOpts = Tcl_NewObj();
- Tcl_IncrRefCount(iPtr->returnOpts);
+ iPtr->returnOpts = NULL;
iPtr->errorInfo = NULL;
iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1);
Tcl_IncrRefCount(iPtr->eiVar);
@@ -992,7 +991,9 @@ DeleteInterpProc(interp)
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
- Tcl_DecrRefCount(iPtr->returnOpts);
+ if (iPtr->returnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ }
Tcl_DecrRefCount(iPtr->returnCodeKey);
Tcl_DecrRefCount(iPtr->returnErrorcodeKey);
Tcl_DecrRefCount(iPtr->returnErrorinfoKey);
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 8d44139..e3c95bd 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.55 2004/10/18 21:15:35 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.56 2004/10/21 15:19:46 dgp Exp $
*/
#include "tclInt.h"
@@ -269,36 +269,9 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
}
}
if (objc == 4) {
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *options = Tcl_DuplicateObj(iPtr->returnOpts);
-
- 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,
- iPtr->returnLevelKey, Tcl_NewIntObj(0));
- }
-
- if (result == TCL_ERROR) {
- /*
- * When result was an error, fill in any missing values
- * for -errorinfo, -errorcode, and -errorline
- */
- 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 ==
- Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) {
+ Tcl_Obj *options = TclGetReturnOptions(interp, result);
+ if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
+ options, 0)) {
Tcl_DecrRefCount(options);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
@@ -582,31 +555,29 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Interp *iPtr = (Interp *) interp;
- char *info;
- int infoLen;
+ Tcl_Obj *options;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
return TCL_ERROR;
}
+ options = Tcl_NewStringObj("-code error -level 0", -1);
+
if (objc >= 3) { /* process the optional info argument */
- info = Tcl_GetStringFromObj(objv[2], &infoLen);
- if (infoLen > 0) {
- Tcl_AddObjErrorInfo(interp, info, infoLen);
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
+ Tcl_ListObjAppendElement(NULL, options,
+ Tcl_NewStringObj("-errorinfo", -1));
+ Tcl_ListObjAppendElement(NULL, options, objv[2]);
}
- if (objc == 4) {
- Tcl_SetObjErrorCode(interp, objv[3]);
- } else {
- Tcl_SetErrorCode(interp, "NONE", NULL);
+ if (objc == 4) { /* process the optional code argument */
+ Tcl_ListObjAppendElement(NULL, options,
+ Tcl_NewStringObj("-errorcode", -1));
+ Tcl_ListObjAppendElement(NULL, options, objv[3]);
}
Tcl_SetObjResult(interp, objv[1]);
- return TCL_ERROR;
+ return TclSetReturnOptions(interp, options);
}
/*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 9a8b617..03a4ccb 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.114 2004/10/18 21:15:35 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.115 2004/10/21 15:19:46 dgp Exp $
*/
#include "tclInt.h"
@@ -868,222 +868,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * 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:
- * None.
- *
- *----------------------------------------------------------------------
- */
-int
-TclProcessReturn(interp, code, level, returnOpts)
- Tcl_Interp *interp;
- int code;
- int level;
- Tcl_Obj *returnOpts;
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *valuePtr;
-
- /* Store the merged return options */
- if (iPtr->returnOpts != returnOpts) {
- Tcl_DecrRefCount(iPtr->returnOpts);
- iPtr->returnOpts = returnOpts;
- Tcl_IncrRefCount(iPtr->returnOpts);
- }
-
- 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_SetObjErrorCode(interp, valuePtr);
- } else {
- Tcl_SetErrorCode(interp, "NONE", NULL);
- }
-
- valuePtr = NULL;
- Tcl_DictObjGet(NULL, iPtr->returnOpts,
- iPtr->returnErrorlineKey, &valuePtr);
- if (valuePtr != NULL) {
- Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
- }
- }
- if (level != 0) {
- iPtr->returnLevel = level;
- iPtr->returnCode = code;
- return 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=TCL_OK;
- int level = 1;
- Tcl_Obj *valuePtr;
- 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);
-
- if ((optLen == compareLen) && (strcmp(opt, compare) == 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_ResetResult(interp);
- Tcl_AppendResult(interp, "bad ",
- compare, " value: expected dictionary but got \"",
- TclGetString(objv[1]), "\"", (char *) NULL);
- goto error;
- }
-
- while (!done) {
- Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
- Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
- }
-
- valuePtr = NULL;
- Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr);
- if (valuePtr != NULL) {
- dict = valuePtr;
- Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey);
- goto nestedOptions;
- }
-
- } else {
- Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
- }
- }
-
- /* Check for bogus -code value */
- Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr);
- if ((valuePtr != NULL)
- && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
- static CONST char *returnCodes[] = {
- "ok", "error", "return", "break", "continue", NULL
- };
-
- if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
- NULL, TCL_EXACT, &code)) {
- /* Value is not a legal return code */
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad completion code \"",
- TclGetString(valuePtr),
- "\": must be ok, error, return, break, ",
- "continue, or an integer", (char *) NULL);
- goto error;
- }
- Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey);
- }
-
- /* Check for bogus -level value */
- Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr);
- 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;
- }
- Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey);
- }
-
- /*
- * Convert [return -code return -level X] to
- * [return -code ok -level X+1]
- */
- if (code == TCL_RETURN) {
- level++;
- code = TCL_OK;
- }
-
- if (codePtr != NULL) {
- *codePtr = code;
- }
- if (levelPtr != NULL) {
- *levelPtr = level;
- }
- if (optionsPtrPtr == NULL) {
- /* Not passing back the options (?!), so clean them up */
- Tcl_DecrRefCount(returnOpts);
- } else {
- *optionsPtrPtr = returnOpts;
- }
- return TCL_OK;
-
-error:
- Tcl_DecrRefCount(returnOpts);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_SourceObjCmd --
*
* This procedure is invoked to process the "source" Tcl command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f2dc36e..90f02ac 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.184 2004/10/21 03:53:04 kennykb Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.185 2004/10/21 15:19:46 dgp Exp $
*/
#ifndef _TCLINT
@@ -1740,6 +1740,8 @@ EXTERN void TclFinalizeAsync _ANSI_ARGS_((void));
EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void));
EXTERN void TclFinalizeLock _ANSI_ARGS_((void));
EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void));
+EXTERN Tcl_Obj * TclGetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
+ int result));
EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
char *pattern, Tcl_Obj *unquotedPrefix,
int globFlags, Tcl_GlobTypeData* types));
@@ -1912,6 +1914,8 @@ EXTERN int TclRestoreInterpState _ANSI_ARGS_ ((
Tcl_Interp *interp, TclInterpState state));
EXTERN TclInterpState TclSaveInterpState _ANSI_ARGS_ ((
Tcl_Interp *interp, int status));
+EXTERN int TclSetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *options));
EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
int result));
EXTERN int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/generic/tclResult.c b/generic/tclResult.c
index de474f7..f2841d9 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.17 2004/10/19 21:54:07 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.18 2004/10/21 15:19:47 dgp Exp $
*/
#include "tclInt.h"
@@ -122,14 +122,23 @@ TclRestoreInterpState(interp, state)
iPtr->returnLevel = statePtr->returnLevel;
iPtr->returnCode = statePtr->returnCode;
+ if (iPtr->errorInfo) {
+ Tcl_DecrRefCount(iPtr->errorInfo);
+ }
iPtr->errorInfo = statePtr->errorInfo;
if (iPtr->errorInfo) {
Tcl_IncrRefCount(iPtr->errorInfo);
}
+ if (iPtr->errorCode) {
+ Tcl_DecrRefCount(iPtr->errorCode);
+ }
iPtr->errorCode = statePtr->errorCode;
if (iPtr->errorCode) {
Tcl_IncrRefCount(iPtr->errorCode);
}
+ if (iPtr->returnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ }
iPtr->returnOpts = statePtr->returnOpts;
if (iPtr->returnOpts) {
Tcl_IncrRefCount(iPtr->returnOpts);
@@ -1052,6 +1061,326 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclProcessReturn(interp, code, level, returnOpts)
+ Tcl_Interp *interp;
+ int code;
+ int level;
+ Tcl_Obj *returnOpts;
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *valuePtr;
+
+ /* Store the merged return options */
+ if (iPtr->returnOpts != returnOpts) {
+ if (iPtr->returnOpts) {
+ Tcl_DecrRefCount(iPtr->returnOpts);
+ }
+ iPtr->returnOpts = returnOpts;
+ Tcl_IncrRefCount(iPtr->returnOpts);
+ }
+
+ if (code == TCL_ERROR) {
+ Tcl_DictObjGet(NULL, iPtr->returnOpts,
+ iPtr->returnErrorinfoKey, &valuePtr);
+ if (valuePtr != NULL) {
+ int infoLen;
+ (void) Tcl_GetStringFromObj(valuePtr, &infoLen);
+ if (infoLen) {
+ if (iPtr->errorInfo) {
+ Tcl_DecrRefCount(iPtr->errorInfo);
+ }
+ iPtr->errorInfo = valuePtr;
+ Tcl_IncrRefCount(iPtr->errorInfo);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
+ }
+ Tcl_DictObjGet(NULL, iPtr->returnOpts,
+ iPtr->returnErrorcodeKey, &valuePtr);
+ if (valuePtr != NULL) {
+ Tcl_SetObjErrorCode(interp, valuePtr);
+ } else {
+ Tcl_SetErrorCode(interp, "NONE", NULL);
+ }
+
+ Tcl_DictObjGet(NULL, iPtr->returnOpts,
+ iPtr->returnErrorlineKey, &valuePtr);
+ if (valuePtr != NULL) {
+ Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
+ }
+ }
+ if (level != 0) {
+ iPtr->returnLevel = level;
+ iPtr->returnCode = code;
+ return 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=TCL_OK;
+ int level = 1;
+ Tcl_Obj *valuePtr;
+ 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);
+
+ if ((optLen == compareLen) && (strcmp(opt, compare) == 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_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad ",
+ compare, " value: expected dictionary but got \"",
+ TclGetString(objv[1]), "\"", (char *) NULL);
+ goto error;
+ }
+
+ while (!done) {
+ Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
+ Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
+ }
+
+ Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr);
+ if (valuePtr != NULL) {
+ dict = valuePtr;
+ Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey);
+ goto nestedOptions;
+ }
+
+ } else {
+ Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
+ }
+ }
+
+ /* Check for bogus -code value */
+ Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr);
+ if ((valuePtr != NULL)
+ && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
+ static CONST char *returnCodes[] = {
+ "ok", "error", "return", "break", "continue", NULL
+ };
+
+ if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
+ NULL, TCL_EXACT, &code)) {
+ /* Value is not a legal return code */
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad completion code \"",
+ TclGetString(valuePtr),
+ "\": must be ok, error, return, break, ",
+ "continue, or an integer", (char *) NULL);
+ goto error;
+ }
+ Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey);
+ }
+
+ /* Check for bogus -level value */
+ Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr);
+ 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;
+ }
+ Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey);
+ }
+
+ /*
+ * Convert [return -code return -level X] to
+ * [return -code ok -level X+1]
+ */
+ if (code == TCL_RETURN) {
+ level++;
+ code = TCL_OK;
+ }
+
+ if (codePtr != NULL) {
+ *codePtr = code;
+ }
+ if (levelPtr != NULL) {
+ *levelPtr = level;
+ }
+ if (optionsPtrPtr == NULL) {
+ /* Not passing back the options (?!), so clean them up */
+ Tcl_DecrRefCount(returnOpts);
+ } else {
+ *optionsPtrPtr = returnOpts;
+ }
+ return TCL_OK;
+
+error:
+ Tcl_DecrRefCount(returnOpts);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclGetReturnOptions --
+ *
+ * Packs up the interp state into a dictionary of return options.
+ *
+ * Results:
+ * A dictionary of return options.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetReturnOptions(interp, result)
+ Tcl_Interp *interp;
+ int result;
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *options;
+
+ if (iPtr->returnOpts) {
+ options = Tcl_DuplicateObj(iPtr->returnOpts);
+ } else {
+ options = Tcl_NewObj();
+ }
+
+ 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,
+ iPtr->returnLevelKey, Tcl_NewIntObj(0));
+ }
+
+ if (result == TCL_ERROR) {
+ /*
+ * When result was an error, fill in any missing values
+ * for -errorinfo, -errorcode, and -errorline
+ */
+ 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));
+ }
+ return options;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclSetReturnOptions --
+ *
+ * Accepts an interp and a dictionary of return options, and sets
+ * the return options of the interp to match the dictionary.
+ *
+ * Results:
+ * A standard status code. Usually TCL_OK, but TCL_ERROR if an
+ * invalid option value was found in the dictionary. If a -level
+ * value of 0 is in the dictionary, then the -code value in the
+ * dictionary will be returned (TCL_OK default).
+ *
+ * Side effects:
+ * Sets the state of the interp.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclSetReturnOptions(interp, options)
+ Tcl_Interp *interp;
+ Tcl_Obj *options;
+{
+ int objc, level, code;
+ Tcl_Obj **objv, *mergedOpts;
+
+ if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv)
+ || (objc % 2)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "expected dict but got \"",
+ Tcl_GetString(options), "\"", NULL);
+ code = TCL_ERROR;
+ } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
+ &mergedOpts, &code, &level)) {
+ code = TCL_ERROR;
+ } else {
+ code = TclProcessReturn(interp, code, level, mergedOpts);
+ }
+
+ Tcl_DecrRefCount(options);
+ return code;
+}
+
+/*
*-------------------------------------------------------------------------
*
* TclTransferResult --
@@ -1093,7 +1422,8 @@ TclTransferResult(sourceInterp, result, targetInterp)
* should be stored. If source and target
* are the same, nothing is done. */
{
- Interp *iPtr;
+ Interp *siPtr = (Interp *) sourceInterp;
+ Interp *tiPtr = (Interp *) targetInterp;
if (sourceInterp == targetInterp) {
return;
@@ -1107,29 +1437,31 @@ TclTransferResult(sourceInterp, result, targetInterp)
* chain, not just a simple error message.
*/
- iPtr = (Interp *) sourceInterp;
- if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
+ if ((siPtr->flags & ERR_ALREADY_LOGGED) == 0) {
Tcl_AddErrorInfo(sourceInterp, "");
}
- iPtr->flags &= ~(ERR_ALREADY_LOGGED);
+ siPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_ResetResult(targetInterp);
- if (iPtr->errorInfo) {
- ((Interp *) targetInterp)->errorInfo = iPtr->errorInfo;
- Tcl_IncrRefCount(((Interp *) targetInterp)->errorInfo);
+ if (siPtr->errorInfo) {
+ tiPtr->errorInfo = siPtr->errorInfo;
+ Tcl_IncrRefCount(tiPtr->errorInfo);
}
- if (iPtr->errorCode) {
- Tcl_SetObjErrorCode(targetInterp, iPtr->errorCode);
+ if (siPtr->errorCode) {
+ Tcl_SetObjErrorCode(targetInterp, siPtr->errorCode);
}
}
/* This may need examination for safety */
- Tcl_DecrRefCount( ((Interp *) targetInterp)->returnOpts );
- ((Interp *) targetInterp)->returnOpts =
- ((Interp *) sourceInterp)->returnOpts;
- Tcl_IncrRefCount( ((Interp *) targetInterp)->returnOpts );
+ if (tiPtr->returnOpts ) {
+ Tcl_DecrRefCount(tiPtr->returnOpts );
+ }
+ tiPtr->returnOpts = siPtr->returnOpts;
+ if (tiPtr->returnOpts ) {
+ Tcl_IncrRefCount(tiPtr->returnOpts );
+ }
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);