* generic/tclBasic.c: Previous fix, now done right.

	* generic/tclCmdIL.c:
	* generic/tclInt.h:
	* tests/unsupported.test:

5 files changed, 65 insertions, 56 deletions

diff --git a/ChangeLog b/ChangeLog
index e753ae9..369f59f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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