* generic/tclInt.h (TclNRSwitchObjCmd):

* generic/tclBasic.c (builtInCmds):
* generic/tclCmdMZ.c (Tcl_SwitchObjCmd):
* tests/switch.test (switch-15.1):
Make non-bytecoded [switch] command aware of NRE. [Bug 2821401]

5 files changed, 65 insertions, 7 deletions

diff --git a/ChangeLog b/ChangeLog
index 717c1d5..4b3545c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2009-07-14  Kevin B. Kenny  <kennykb@acm.org>
+
+	* generic/tclInt.h (TclNRSwitchObjCmd):
+	* generic/tclBasic.c (builtInCmds):
+	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd):
+	* tests/switch.test (switch-15.1):
+	Make non-bytecoded [switch] command aware of NRE. [Bug 2821401]
+	
 2009-07-13  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclCompile.c (TclInitCompileEnv, EnterCmdWordIndex,
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a097976..fcc7d46 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,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.395 2009/07/14 16:34:08 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.396 2009/07/14 16:52:28 kennykb Exp $
  */
 
 #include "tclInt.h"
@@ -214,7 +214,7 @@ static const CmdInfo builtInCmds[] = {
     {"set",		Tcl_SetObjCmd,		TclCompileSetCmd,	NULL,	1},
     {"split",		Tcl_SplitObjCmd,	NULL,			NULL,	1},
     {"subst",		Tcl_SubstObjCmd,	NULL,			NULL,	1},
-    {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	NULL,	1},
+    {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, 1},
     {"throw",		Tcl_ThrowObjCmd,	NULL,			NULL,	1},
     {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	1},
     {"try",		Tcl_TryObjCmd,		NULL,			TclNRTryObjCmd,	1},
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d6f2987..9d416bc 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.185 2009/07/14 16:34:08 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.186 2009/07/14 16:52:28 kennykb Exp $
  */
 
 #include "tclInt.h"
@@ -23,6 +23,8 @@
 
 static inline Tcl_Obj *	During(Tcl_Interp *interp, int resultCode,
 			    Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
+static int		SwitchPostProc(ClientData data[], Tcl_Interp* interp,
+				       int result);
 static int		TryPostBody(ClientData data[], Tcl_Interp *interp,
 			    int result);
 static int		TryPostFinal(ClientData data[], Tcl_Interp *interp,
@@ -3426,7 +3428,16 @@ Tcl_SwitchObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved;
+    return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv);
+}
+int 
+TclNRSwitchObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    int i,j, index, mode, foundmode, splitObjs, numMatchesSaved;
     int noCase, patternLength;
     const char *pattern;
     Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
@@ -3853,7 +3864,29 @@ Tcl_SwitchObjCmd(
      * TIP #280: Make invoking context available to switch branch.
      */
 
-    result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, j);
+    Tcl_NRAddCallback(interp, SwitchPostProc, (ClientData) splitObjs,
+		      (ClientData) ctxPtr, (ClientData) pc,
+		      (ClientData) pattern);
+    return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, j);
+}
+static int
+SwitchPostProc(
+    ClientData data[],		/* Data passed from Tcl_NRAddCallback above */
+    Tcl_Interp* interp,		/* Tcl interpreter */
+    int result)			/* Result to return*/
+{
+    /* Unpack the preserved data */
+
+    int splitObjs = (int) data[0];
+    CmdFrame* ctxPtr = (CmdFrame*) data[1];
+    int pc = (int) data[2];
+    const char* pattern = (const char*) data[3];
+    int patternLength = strlen(pattern);
+
+    /*
+     * Clean up TIP 280 context information
+     */
+
     if (splitObjs) {
 	ckfree((char *) ctxPtr->line);
 	if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7374b23..8c5cf3d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.428 2009/07/14 16:34:09 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.429 2009/07/14 16:52:28 kennykb Exp $
  */
 
 #ifndef _TCLINT
@@ -2602,6 +2602,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
diff --git a/tests/switch.test b/tests/switch.test
index 2652a70..738565f 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -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: switch.test,v 1.24 2009/06/24 15:17:41 dgp Exp $
+# RCS: @(#) $Id: switch.test,v 1.25 2009/07/14 16:52:28 kennykb Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -738,6 +738,22 @@ test switch-14.16 {switch -regexp compilation} {
     }}
 } no
 
+test switch-15.1 {coroutine safety of non-bytecoded switch} {*}{
+    -body {
+	proc coro {} {
+	    switch -glob a {
+		a {yield ok1}
+	    }
+	    return ok2
+	}
+	list [coroutine c coro] [c]
+    }
+    -result {ok1 ok2}
+    -cleanup {
+	rename coro {}
+    }
+}
+
 # cleanup
 catch {rename foo {}}
 ::tcltest::cleanupTests