diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 39 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | tests/switch.test | 18 |
5 files changed, 65 insertions, 7 deletions
@@ -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 |