* generic/tclInt.decls: New internal routine TclBackgroundException()

        * generic/tclEvent.c:   that for the first time permits non-TCL_ERROR
        exceptions to trigger [interp bgerror] handling.  Closes a gap in
        TIP 221.  When falling back to [bgerror] (which is designed only
        to handle TCL_ERROR), convert exceptions into errors complaining
        about the exception.

        * generic/tclInterp.c:  Convert Tcl_BackgroundError() callers to call
        * generic/tclIO.c:      TclBackgroundException().
        * generic/tclIOCmd.c:
        * generic/tclTimer.c:

        * generic/tclIntDecls.h:        make genstubs
        * generic/tclStubInit.c:

9 files changed, 135 insertions, 41 deletions

diff --git a/ChangeLog b/ChangeLog
index 20ea4bf..b883584 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2007-09-06  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclInt.decls:	New internal routine TclBackgroundException()
+	* generic/tclEvent.c:	that for the first time permits non-TCL_ERROR
+	exceptions to trigger [interp bgerror] handling.  Closes a gap in
+	TIP 221.  When falling back to [bgerror] (which is designed only
+	to handle TCL_ERROR), convert exceptions into errors complaining
+	about the exception.
+
+	* generic/tclInterp.c:	Convert Tcl_BackgroundError() callers to call
+	* generic/tclIO.c:	TclBackgroundException().
+	* generic/tclIOCmd.c:
+	* generic/tclTimer.c:
+	
+	* generic/tclIntDecls.h:	make genstubs
+	* generic/tclStubInit.c:
+
 2007-09-06  Daniel Steffen  <das@users.sourceforge.net>
 
 	* macosx/Tcl.xcode/project.pbxproj: discontinue unmaintained support
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 52fd371..4b37b1e 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -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: tclEvent.c,v 1.73 2007/07/02 17:13:48 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.74 2007/09/06 18:13:19 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -140,13 +140,25 @@ Tcl_BackgroundError(
     Tcl_Interp *interp)		/* Interpreter in which an error has
 				 * occurred. */
 {
+    TclBackgroundException(interp, TCL_ERROR);
+}
+void
+TclBackgroundException(
+    Tcl_Interp *interp,		/* Interpreter in which an exception has
+				 * occurred. */
+    int code)			/* The exception code value */
+{
     BgError *errPtr;
     ErrAssocData *assocPtr;
 
+    if (code == TCL_OK) {
+	return;
+    }
+
     errPtr = (BgError *) ckalloc(sizeof(BgError));
     errPtr->errorMsg = Tcl_GetObjResult(interp);
     Tcl_IncrRefCount(errPtr->errorMsg);
-    errPtr->returnOpts = Tcl_GetReturnOptions(interp, TCL_ERROR);
+    errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
     Tcl_IncrRefCount(errPtr->returnOpts);
     errPtr->nextPtr = NULL;
 
@@ -297,45 +309,86 @@ TclDefaultBgErrorHandlerObjCmd(
 {
     Tcl_Obj *keyPtr, *valuePtr;
     Tcl_Obj *tempObjv[2];
-    int code;
+    int code, level;
 
     if (objc != 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "msg options");
 	return TCL_ERROR;
     }
 
+    /* Construct the bgerror command */
+    TclNewLiteralStringObj(tempObjv[0], "bgerror");
+    Tcl_IncrRefCount(tempObjv[0]);
+
     /*
-     * Restore important state variables to what they were at the time the
-     * error occurred.
-     *
-     * Need to set the variables, not the interp fields, because Tcl_EvalObjv
-     * calls Tcl_ResetResult which would destroy anything we write to the
-     * interp fields.
+     * Determine error message argument.  Check the return options in case
+     * a non-error exception brought us here.
      */
 
-    TclNewLiteralStringObj(keyPtr, "-errorcode");
+    TclNewLiteralStringObj(keyPtr, "-level");
     Tcl_IncrRefCount(keyPtr);
     Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
     Tcl_DecrRefCount(keyPtr);
-    if (valuePtr) {
-	Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
+    Tcl_GetIntFromObj(NULL, valuePtr, &level);
+    if (level != 0) {
+	/* We're handling a TCL_RETURN exception */
+	code = TCL_RETURN;
+    } else {
+	TclNewLiteralStringObj(keyPtr, "-code");
+	Tcl_IncrRefCount(keyPtr);
+	Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+	Tcl_DecrRefCount(keyPtr);
+	Tcl_GetIntFromObj(NULL, valuePtr, &code);
     }
-
-    TclNewLiteralStringObj(keyPtr, "-errorinfo");
-    Tcl_IncrRefCount(keyPtr);
-    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
-    Tcl_DecrRefCount(keyPtr);
-    if (valuePtr) {
-	Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
+    switch (code) {
+    case TCL_ERROR:
+	tempObjv[1] = objv[1];
+	break;
+    case TCL_BREAK:
+	TclNewLiteralStringObj(tempObjv[1],
+		"invoked \"break\" outside of a loop");
+	break;
+    case TCL_CONTINUE:
+	TclNewLiteralStringObj(tempObjv[1],
+		"invoked \"continue\" outside of a loop");
+	break;
+    default:
+	tempObjv[1] = Tcl_ObjPrintf("command returned bad code: %d", code);
+	break;
     }
+    if (code == TCL_ERROR) {
+	/*
+	 * Restore important state variables to what they were at the time
+	 * the error occurred.
+	 *
+	 * Need to set the variables, not the interp fields, because
+	 * Tcl_EvalObjv calls Tcl_ResetResult which would destroy
+	 * anything we write to the interp fields.
+	 */
 
-    /*
-     * Create and invoke the bgerror command.
-     */
+	TclNewLiteralStringObj(keyPtr, "-errorcode");
+	Tcl_IncrRefCount(keyPtr);
+	Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+	Tcl_DecrRefCount(keyPtr);
+	if (valuePtr) {
+	    Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
+	}
 
-    TclNewLiteralStringObj(tempObjv[0], "bgerror");
-    Tcl_IncrRefCount(tempObjv[0]);
-    tempObjv[1] = objv[1];
+	TclNewLiteralStringObj(keyPtr, "-errorinfo");
+	Tcl_IncrRefCount(keyPtr);
+	Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+	Tcl_DecrRefCount(keyPtr);
+	if (valuePtr) {
+	    Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
+	}
+    } else {
+	Tcl_AppendObjToErrorInfo(interp, Tcl_DuplicateObj(tempObjv[1]));
+    }
+    Tcl_IncrRefCount(tempObjv[1]);
+    valuePtr = Tcl_GetVar2Ex(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
+    Tcl_IncrRefCount(valuePtr);
+
+    /* Invoke the bgerror command. */
     Tcl_AllowExceptions(interp);
     code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
     if (code == TCL_ERROR) {
@@ -368,7 +421,7 @@ TclDefaultBgErrorHandlerObjCmd(
 		    Tcl_WriteChars(errChannel,
 			    "bgerror failed to handle background error.\n",-1);
 		    Tcl_WriteChars(errChannel, "    Original error: ", -1);
-		    Tcl_WriteObj(errChannel, objv[1]);
+		    Tcl_WriteObj(errChannel, tempObjv[1]);
 		    Tcl_WriteChars(errChannel, "\n", -1);
 		    Tcl_WriteChars(errChannel, "    Error in bgerror: ", -1);
 		    Tcl_WriteObj(errChannel, resultPtr);
@@ -380,7 +433,9 @@ TclDefaultBgErrorHandlerObjCmd(
 	}
 	code = TCL_OK;
     }
+    Tcl_DecrRefCount(valuePtr);
     Tcl_DecrRefCount(tempObjv[0]);
+    Tcl_DecrRefCount(tempObjv[1]);
     Tcl_ResetResult(interp);
     return code;
 }
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 4e1c56b..145d27a 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.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: tclIO.c,v 1.122 2007/07/02 19:18:10 dgp Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.123 2007/09/06 18:13:19 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -7932,7 +7932,7 @@ TclChannelEventScriptInvoker(
 	if (chanPtr->typePtr != NULL) {
 	    DeleteScriptRecord(interp, chanPtr, mask);
 	}
-	Tcl_BackgroundError(interp);
+	TclBackgroundException(interp, result);
     }
     Tcl_Release((ClientData) interp);
 }
@@ -8394,6 +8394,7 @@ CopyData(
 
     total = csPtr->total;
     if (cmdPtr && interp) {
+	int code;
 	/*
 	 * Get a private copy of the command so we can mutate it by adding
 	 * arguments. Note that StopCopy frees our saved reference to the
@@ -8409,8 +8410,9 @@ CopyData(
 	if (errObj) {
 	    Tcl_ListObjAppendElement(interp, cmdPtr, errObj);
 	}
-	if (Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
-	    Tcl_BackgroundError(interp);
+	code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+	if (code != TCL_OK) {
+	    TclBackgroundException(interp, code);
 	    result = TCL_ERROR;
 	}
 	TclDecrRefCount(cmdPtr);
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index ba610b5..9156b6d 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.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: tclIOCmd.c,v 1.42 2007/06/28 21:10:38 patthoyts Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.43 2007/09/06 18:13:20 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1284,7 +1284,7 @@ AcceptCallbackProc(
 	result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
 		" ", address, " ", portBuf, NULL);
 	if (result != TCL_OK) {
-	    Tcl_BackgroundError(interp);
+	    TclBackgroundException(interp, result);
 	    Tcl_UnregisterChannel(interp, chan);
 	}
 
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index ab6252a..57611b9 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -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.decls,v 1.113 2007/08/07 17:28:38 msofer Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.114 2007/09/06 18:13:20 dgp Exp $
 
 library tcl
 
@@ -937,6 +937,12 @@ declare 235 generic {
     void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
 }
 
+
+declare 236 generic {
+    void TclBackgroundException(Tcl_Interp *interp, int code)
+}
+
+
 ##############################################################################
 
 # Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 876a4bf..157b189 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -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: tclIntDecls.h,v 1.104 2007/08/07 17:28:39 msofer Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.105 2007/09/06 18:13:20 dgp Exp $
  */
 
 #ifndef _TCLINTDECLS
@@ -1051,6 +1051,12 @@ EXTERN Var *		TclVarHashCreateVar (TclVarHashTable * tablePtr,
 EXTERN void		TclInitVarHashTable (TclVarHashTable * tablePtr, 
 				Namespace * nsPtr);
 #endif
+#ifndef TclBackgroundException_TCL_DECLARED
+#define TclBackgroundException_TCL_DECLARED
+/* 236 */
+EXTERN void		TclBackgroundException (Tcl_Interp * interp, 
+				int code);
+#endif
 
 typedef struct TclIntStubs {
     int magic;
@@ -1307,6 +1313,7 @@ typedef struct TclIntStubs {
     void (*tclGetSrcInfoForPc) (CmdFrame * contextPtr); /* 233 */
     Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */
     void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */
+    void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */
 } TclIntStubs;
 
 #ifdef __cplusplus
@@ -2036,6 +2043,10 @@ extern TclIntStubs *tclIntStubsPtr;
 #define TclInitVarHashTable \
 	(tclIntStubsPtr->tclInitVarHashTable) /* 235 */
 #endif
+#ifndef TclBackgroundException
+#define TclBackgroundException \
+	(tclIntStubsPtr->tclBackgroundException) /* 236 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 1d28a95..a42c339 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.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: tclInterp.c,v 1.76 2007/06/20 18:46:13 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.77 2007/09/06 18:13:20 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3615,12 +3615,14 @@ TimeLimitCallback(
     ClientData clientData)
 {
     Tcl_Interp *interp = (Tcl_Interp *) clientData;
+    int code;
 
     Tcl_Preserve((ClientData) interp);
     ((Interp *)interp)->limit.timeEvent = NULL;
-    if (Tcl_LimitCheck(interp) != TCL_OK) {
+    code = Tcl_LimitCheck(interp);
+    if (code != TCL_OK) {
 	Tcl_AddErrorInfo(interp, "\n    (while waiting for event)");
-	Tcl_BackgroundError(interp);
+	TclBackgroundException(interp, code);
     }
     Tcl_Release((ClientData) interp);
 }
@@ -3788,7 +3790,7 @@ CallScriptLimitCallback(
     code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj,
 	    TCL_EVAL_GLOBAL);
     if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) {
-	Tcl_BackgroundError(limitCBPtr->interp);
+	TclBackgroundException(limitCBPtr->interp, code);
     }
     Tcl_Release(limitCBPtr->interp);
 }
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index b197f66..15e963b 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.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: tclStubInit.c,v 1.143 2007/08/07 17:28:39 msofer Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.144 2007/09/06 18:13:23 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -325,6 +325,7 @@ TclIntStubs tclIntStubs = {
     TclGetSrcInfoForPc, /* 233 */
     TclVarHashCreateVar, /* 234 */
     TclInitVarHashTable, /* 235 */
+    TclBackgroundException, /* 236 */
 };
 
 TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 3e5ad1a..a14a129 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclTimer.c,v 1.28 2006/11/15 20:08:45 dgp Exp $
+ * RCS: @(#) $Id: tclTimer.c,v 1.29 2007/09/06 18:13:23 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1155,7 +1155,7 @@ AfterProc(
 #endif
     if (result != TCL_OK) {
 	Tcl_AddErrorInfo(interp, "\n    (\"after\" script)");
-	Tcl_BackgroundError(interp);
+	TclBackgroundException(interp, result);
     }
     Tcl_Release((ClientData) interp);