summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdMZ.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdMZ.c')
-rw-r--r--generic/tclCmdMZ.c218
1 files changed, 1 insertions, 217 deletions
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.