summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2009-07-14 16:52:28 (GMT)
committerKevin B Kenny <kennykb@acm.org>2009-07-14 16:52:28 (GMT)
commit67e100ed95642d0ec30b5718d5c2eb66535c3cbe (patch)
tree3f792ab808ad24f569fa00894c9bab62e4972d9f
parent08604cad04da0d67c84406f99bda814f6a416386 (diff)
downloadtcl-67e100ed95642d0ec30b5718d5c2eb66535c3cbe.zip
tcl-67e100ed95642d0ec30b5718d5c2eb66535c3cbe.tar.gz
tcl-67e100ed95642d0ec30b5718d5c2eb66535c3cbe.tar.bz2
* 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]
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdMZ.c39
-rw-r--r--generic/tclInt.h3
-rw-r--r--tests/switch.test18
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