diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 11 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 70 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | tests/unsupported.test | 30 |
5 files changed, 65 insertions, 56 deletions
@@ -1,3 +1,10 @@ +2008-08-21 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: Previous fix, now done right. + * generic/tclCmdIL.c: + * generic/tclInt.h: + * tests/unsupported.test: + 2008-08-21 Jeff Hobbs <jeffh@ActiveState.com> * tests/regexp.test, tests/regexpComp.test: correct re2glob ***= diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b50234b..53be9de 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.358 2008/08/21 21:01:23 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.359 2008/08/21 23:57:42 msofer Exp $ */ #include "tclInt.h" @@ -8173,7 +8173,6 @@ PlugCoroutineChains( corPtr->base.framePtr->callerVarPtr = corPtr->caller.varFramePtr; corPtr->base.cmdFramePtr->nextPtr = corPtr->caller.cmdFramePtr; - corPtr->levelOffset = iPtr->cmdFramePtr->level; } static int @@ -8190,12 +8189,6 @@ NRCoroutineFirstCallback( tmpPtr = tmpPtr->nextPtr; } - /* - * Set the base cmdFrame level to zero, it will be computed using the - * offset. - */ - - tmpPtr->level = 0; corPtr->base.cmdFramePtr = tmpPtr; } @@ -8396,8 +8389,6 @@ TclNRCoroutineObjCmd( * correct. The offset will be fixed for later runs. */ - corPtr->levelOffset = 0; - Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, nsPtr->fullName, -1); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index d6d0b09..a96f555 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.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: tclCmdIL.c,v 1.150 2008/08/21 21:24:53 msofer Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.151 2008/08/21 23:57:43 msofer Exp $ */ #include "tclInt.h" @@ -1043,30 +1043,29 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level; + int level, topLevel; CmdFrame *framePtr; - int absoluteLevel = ((iPtr->cmdFramePtr == NULL) + + topLevel = ((iPtr->cmdFramePtr == NULL) ? 0 : iPtr->cmdFramePtr->level); + if (iPtr->execEnvPtr->corPtr) { /* - * We are running within a coroutine, the levels are relative to the - * coroutine's initial frame: do the correction here. + * A coroutine: must fix the level computations */ - absoluteLevel += iPtr->execEnvPtr->corPtr->levelOffset; + topLevel += iPtr->execEnvPtr->corPtr->caller.cmdFramePtr->level + 1 - + iPtr->execEnvPtr->corPtr->base.cmdFramePtr->level; } - + if (objc == 1) { /* * Just "info frame". */ - int levels = - (iPtr->cmdFramePtr == NULL ? 0 : absoluteLevel); - - Tcl_SetObjResult(interp, Tcl_NewIntObj (levels)); + Tcl_SetObjResult(interp, Tcl_NewIntObj (topLevel)); return TCL_OK; } else if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); @@ -1080,44 +1079,29 @@ InfoFrameCmd( if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { return TCL_ERROR; } - if (level <= 0) { - /* - * Negative levels are adressing relative to the current frame's - * depth. - */ - - if (iPtr->cmdFramePtr == NULL) { - levelError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", - TclGetString(objv[1]), "\"", NULL); - return TCL_ERROR; - } - /* - * Convert to absolute. - */ + if ((level > topLevel) || (level <= - topLevel)) { + levelError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", + TclGetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + + /* + * Let us convert to relative so that we know how many levels to go back + */ - level += iPtr->cmdFramePtr->level; + if (level > 0) { + level -= topLevel; } - for (framePtr = iPtr->cmdFramePtr; framePtr != NULL; - framePtr = framePtr->nextPtr) { - absoluteLevel = framePtr->level; - if (iPtr->execEnvPtr->corPtr) { - /* - * We are running within a coroutine, the levels are relative to - * the coroutine's initial frame: do the correction here. - */ - - absoluteLevel += iPtr->execEnvPtr->corPtr->levelOffset; - } - if (absoluteLevel == level) { - break; + framePtr = iPtr->cmdFramePtr; + while (++level <= 0) { + framePtr = framePtr->nextPtr; + if (!framePtr) { + goto levelError; } } - if (framePtr == NULL) { - goto levelError; - } Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); return TCL_OK; diff --git a/generic/tclInt.h b/generic/tclInt.h index 1b2014b..7084cd1 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.393 2008/08/21 21:01:25 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.394 2008/08/21 23:57:43 msofer Exp $ */ #ifndef _TCLINT @@ -1347,7 +1347,6 @@ typedef struct CoroutineData { CorContext caller; CorContext running; CorContext base; - int levelOffset; int *stackLevel; } CoroutineData; diff --git a/tests/unsupported.test b/tests/unsupported.test index 48cd130..87db81d 100644 --- a/tests/unsupported.test +++ b/tests/unsupported.test @@ -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: unsupported.test,v 1.4 2008/08/17 19:37:13 msofer Exp $ +# RCS: @(#) $Id: unsupported.test,v 1.5 2008/08/21 23:57:43 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -717,6 +717,34 @@ test unsupported-C.2.6 {deletion of running coroutine} -constraints {coroutine} list [foo] [catch foo msg] $msg } -result {1 1 {invalid command name "foo"}} +test unsupported-C.3.1 {info level computation} -constraints {coroutine} \ +-setup { + proc a {} {while 1 {yield [info level]}} + proc b {} foo +} -body { + # note that coroutines execute in uplevel #0 + set l0 [coroutine foo a] + set l1 [foo] + set l2 [b] + list $l0 $l1 $l2 +} -cleanup { + rename a {} + rename b {} +} -result {1 1 1} + +test unsupported-C.3.2 {info frame computation} -constraints {coroutine} \ +-setup { + proc a {} {while 1 {yield [info frame]}} + proc b {} foo +} -body { + set l0 [coroutine foo a] + set l1 [foo] + set l2 [b] + expr {$l2 - $l1} +} -cleanup { + rename a {} + rename b {} +} -result 1 # cleanup |