Tcl Source Code

Artifact c0aa8c84a5fc20b1a33a1ecf1bf21c8cd498377d:

Attachment "tclResult.c.patch" to ticket [2974744fff] added by nijtmans 2010-03-23 20:51:34.

---

Index: tclResult.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclResult.c,v
retrieving revision 1.57
diff -c -r1.57 tclResult.c
*** tclResult.c	24 Feb 2010 10:45:04 -0000	1.57
--- tclResult.c	23 Mar 2010 13:48:48 -0000
***************
*** 1292,1303 ****
  /*
   *----------------------------------------------------------------------
   *
   * 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.
   *
--- 1292,1352 ----
  /*
   *----------------------------------------------------------------------
   *
+  * Tcl_GetCompletionCodeFromObj --
+  *
+  *	Parses Completion code Code
+  *
+  * Results:
+  *	Returns TCL_ERROR if the value is an invalid completion code.
+  *	Otherwise, returns TCL_OK, and writes the completion code to
+  *  the pointer provided.
+  *
+  * Side effects:
+  *	None.
+  *
+  *----------------------------------------------------------------------
+  */
+ 
+ int
+ Tcl_GetCompletionCodeFromObj(
+     Tcl_Interp *interp,		/* Current interpreter. */
+     Tcl_Obj *value,
+     int *code)	/* Argument objects. */
+ {
+     if (TCL_ERROR == TclGetIntFromObj(NULL, value, code)) {
+ 	static const char *const returnCodes[] = {
+ 	    "ok", "error", "return", "break", "continue", NULL
+ 	};
+ 
+ 	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, value, returnCodes,
+ 		NULL, TCL_EXACT, code)) {
+ 	    /*
+ 	     * Value is not a legal return code.
+ 	     */
+ 
+ 	    if (interp != NULL) {
+ 		Tcl_ResetResult(interp);
+ 		Tcl_AppendResult(interp, "bad completion code \"",
+ 			TclGetString(value),
+ 			"\": must be ok, error, return, break, "
+ 			"continue, or an integer", NULL);
+ 		Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
+ 	    }
+ 	    return TCL_ERROR;
+ 	}
+     }
+     return TCL_OK;
+ }
+ 
+ /*
+  *----------------------------------------------------------------------
+  *
   * TclMergeReturnOptions --
   *
   *	Parses, checks, and stores the options to the [return] command.
   *
   * Results:
!  *	Returns TCL_ERROR if any of the option values are invalid. Otherwise,
   *	returns TCL_OK, and writes the returnOpts, code, and level values to
   *	the pointers provided.
   *
***************
*** 1377,1404 ****
       */
  
      Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
!     if ((valuePtr != NULL)
! 	    && (TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &code))) {
! 	static const char *const 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", NULL);
! 	    Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
  	    goto error;
  	}
-     }
-     if (valuePtr != NULL) {
  	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
      }
  
--- 1426,1435 ----
       */
  
      Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
!     if (valuePtr != NULL) {
! 	if (TCL_ERROR == Tcl_GetCompletionCodeFromObj(interp, valuePtr, &code)) {
  	    goto error;
  	}
  	Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
      }